Coverage report: /development/source/library/org/datagraph/spocq-shard/src/core/utilities.lisp

Kind	Covered	All	%
expression	3079	7816	39.4
branch	261	730	35.8

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.datagraph.spocq.implementation; -*-

2

3

(in-package :org.datagraph.spocq.implementation)

4

5

(require-features (or :digitool :sbcl :clozure :lispworks)

6

"This file must be conditionalized for ~a."

7

(lisp-implementation-type))

8

9

(defgeneric describe-class-list (designator)

10

(:method ((name symbol))

11

(let ((class (find-class name nil)))

12

(cond (class

13

(describe-class-list class))

14

(t

15

nil))))

16

(:method ((class class))

17

(let ((info (sb-kernel::info :type :classoid-cell (class-name class)))

18

(cell (sb-kernel::find-classoid-cell (class-name class)))

19

(classoid (sb-kernel::find-classoid (class-name class))))

20

`( ,(class-name class)

21

:info ,info

22

:cell ,cell

23

:classoid ,classoid))))

24

(defun describe-class (class &optional (stream *trace-output*))

25

(pprint (describe-class-list class) stream)

26

(terpri stream)

27

(finish-output stream))

28

29

;;; cl-ppcre patches

30

31

(defmethod make-load-form ((str ppcre::str) &optional environment)

32

(make-load-form-saving-slots str :environment environment))

33

34

(defun call-packaged-macro-character (stream char function-name original-readtable)

35

(let ((actual-reader (find-symbol (symbol-name function-name) *package*)))

36

(cond (actual-reader

37

(funcall actual-reader stream char))

38

(t

39

(unread-char char stream)

40

(let ((*readtable* original-readtable))

41

(read stream))))))

42

43

 (defun call-packaged-dispatch-macro-character (stream char arg function-name original-readtable original-reader)

44

(let ((actual-reader (find-symbol (symbol-name function-name) *package*)))

45

(cond (actual-reader

46

(funcall actual-reader stream char arg))

47

(original-reader

48

(let ((*readtable* original-readtable))

49

(funcall original-reader char arg)))

50

(t

51

(unread-char char stream)

52

;;(error "No reader macro defined for the dispatch: ~s ~s." char arg)

53

(let ((*readtable* original-readtable))

54

(read stream))))))

55

56

57

58

(defun set-packaged-macro-character (character function-name &optional (readtable *readtable*))

59

(let ((original-reader (get-macro-character character (copy-readtable nil)))

60

(original-readtable (copy-readtable readtable)))

61

(flet ((maybe-reader (stream char)

62

(call-packaged-macro-character stream char function-name original-readtable)))

63

(when original-reader

64

(set-macro-character character original-reader original-readtable))

65

(set-macro-character character #'maybe-reader *readtable*))))

66

67

 (defun set-packaged-dispatch-macro-character (dispatch character function-name &optional (readtable *readtable*))

68

(let ((original-reader (get-dispatch-macro-character dispatch character (copy-readtable nil)))

69

(original-readtable (copy-readtable readtable)))

70

(flet ((maybe-reader (stream char arg)

71

(call-packaged-dispatch-macro-character stream char arg function-name

72

                                                      original-readtable original-reader)))

73

(when original-reader

74

(set-dispatch-macro-character dispatch character original-reader original-readtable))

75

(set-dispatch-macro-character dispatch character #'maybe-reader *readtable*))))

76

77

(defun read-regex-function (stream &rest args)

78

(declare (ignore args))

79

(let ((pattern (read stream t nil t)))

80

(assert (stringp pattern) ()

81

"Invalid regular expression pattern: ~s" pattern)

82

`(lambda (string)

83

(cl-ppcre:scan-to-strings (load-time-value (cl-ppcre:create-scanner ,pattern))

84

string))))

85

86

(set-dispatch-macro-character #\# #\~ 'read-regex-function)

87

88

89

;;; patches in general

90

91

(defun load-patch (pathname &key description)

92

(load pathname)

93

(push `(:pathname ,pathname :time ,(get-universal-time) ,@(when description `(:description ,description)))

94

*patches*))

95

96

(defun build-revisions ()

97

`(:spocq.i ,*build-revision*

98

,@(when (boundp 'dydra-ndk::*build-revision*)

99

`(:dydra-ndk ,(symbol-value 'dydra-ndk::*build-revision*)))))

100

101

;;; i/o utilities

102

103

(defgeneric stream-write-external-utf8-string (stream %string)

104

(:method ((stream amqp:channel) %string)

105

(loop for i from 0

106

for byte = (cffi:mem-ref %string :uint8 i)

107

until (zerop byte)

108

do (amqp.i::amqp-stream-write-byte stream byte)))

109

(:method ((stream stream) %string)

110

(write-string (cffi:foreign-string-to-lisp %string) stream)))

111

112

113

;;;

114

;;; macros

115

116

(defmacro undefun (name parameters &body body)

117

(declare (ignore name parameters body))

118

;(warn "not defining: ~s ~s" name parameters)

119

(values ))

120

121

(defmacro undefmethod (name parameters &body body)

122

(declare (ignore name parameters body))

123

;;(warn "not defining: ~s ~s" name parameters)

124

(values ))

125

126

(defmacro undefgeneric (name parameters &body body)

127

(declare (ignore name parameters body))

128

;(warn "not defining: ~s ~s" name parameters)

129

(values ))

130

131

(defmacro term-number-typecase (term-number &rest body)

132

(let ((op (gensym (string 'term-number-typecase)))

133

(type (gensym (string 'type))))

134

`(flet ((,op (,type) (case ,type ,@body)))

135

(declare (dynamic-extent #',op))

136

(call-with-term-number-type #',op ,term-number))))

137

138

(defmacro with-term-record ((record) &body body)

139

`(cffi:with-foreign-object (,record '(:struct rdfcache::term))

140

,@body))

141

142

(defmacro with-cursor-record ((record) &body body)

143

`(cffi:with-foreign-object (,record '(:struct rdfcache::cursor))

144

,@body))

145

146

(defmacro _print-unreadable-object ((object stream &rest args) &body body)

147

`((lambda (object stream)

148

(handler-case (print-unreadable-object (object stream ,@args) ,@body)

149

(error (c)

150

(ignore-errors (print-unreadable-object (object stream :identity t :type t)

151

(format stream "error printing object: ~a" c))))))

152

,object ,stream))

153

#+digitool

154

(setf (ccl:assq '_print-unreadable-object ccl:*fred-special-indent-alist*) 1)

155

156

(defmacro do-statements ((term-match-variables transaction context subject predicate object)

157

&body body)

158

"Given a repository handle and a term pattern, iterate over

159

    the matching term combinations with each match variable bound to the respective term. If a variable

160

position is nil, that term is ignored."

161

162

(let ((parameter-list (loop for variable in term-match-variables

163

if variable collect variable

164

else collect (gensym))))

165

`(flet ((each-statement ,parameter-list

166

,@(unless (every #'symbol-package parameter-list)

167

`((declare (ignore ,@(remove-if #'symbol-package parameter-list)))))

168

,@body))

169

(declare (dynamic-extent #'each-statement))

170

(map-statements #'each-statement ,transaction

171

,context ,subject ,predicate ,object))))

172

173

174

(defmacro with-matched-terms (((g s p o) &key (subject '(repository-wildcard-term *transaction*))

175

(predicate '(repository-wildcard-term *transaction*))

176

(object '(repository-wildcard-term *transaction*))

177

(graph nil g-s))

178

&body body)

179

(let ((op (gensym "matchop")))

180

`(flet ((,op (,g ,s ,p ,o)

181

(declare (ignorable ,g ,s ,p ,o))

182

,@body))

183

(declare (dynamic-extent #',op))

184

        (repository-call-with-matched-terms #',op *transaction* ,subject ,predicate ,object ,@(when g-s `(:content ,graph))))))

185

186

(defmacro with-numbered-term ((term number &key (context '*transaction*)) &body body)

187

(let ((op (gensym)))

188

`(flet ((,op (,term)

189

(declare (type cffi:foreign-pointer ,term ))

190

,@body))

191

(declare (dynamic-extent #',op))

192

(repository-call-with-numbered-term #',op ,context ,number))))

193

194

 (defmacro with-numbered-term-aspects (((type literal tag datatype) number &key (context '*transaction*)) &body body)

195

(let ((op (gensym)))

196

`(flet ((,op (,type ,literal ,tag ,datatype)

197

(declare (type cffi:foreign-pointer ,literal ,tag ,datatype))

198

,@body))

199

(declare (dynamic-extent #',op))

200

(repository-call-with-numbered-term-aspects #',op ,context ,number))))

201

202

(defmacro with-rdfcache-cursor ((cursor) &body body)

203

(let ((op (gensym "with-query-cursor")))

204

`(flet ((,op (,cursor) ,@body))

205

(declare (dynamic-extent #',op))

206

(call-with-rdfcache-cursor #',op))))

207

208

#+(or)

209

(progn

210

; monolithic decoding

211

(defmacro with-term-string ((string %term-string) &body body)

212

`(let* ((.term-value-len. (rdfcache::%%utf8-get-length ,%term-string))

213

(.term-value-ptr. ,%term-string)

214

(,string (make-string .term-value-len.)))

215

(declare (type rdfcache::foreign-pointer ,%term-string .term-value-ptr.)

216

(type fixnum .term-value-len.)

217

(type simple-string ,string)

218

(dynamic-extent ,string))

219

(dotimes (.term-value-pos. .term-value-len.)

220

(declare (type fixnum .term-value-pos.))

221

(let ((.term-value-chr. (rdfcache::%%utf8-get-char .term-value-ptr.)))

222

(declare (type fixnum .term-value-chr.))

223

(setf (char ,string .term-value-pos.) (code-char .term-value-chr.)))

224

(setq .term-value-ptr. (rdfcache::%%utf8-next-char .term-value-ptr.)))

225

,@body))

226

227

; by hand decoding

228

(defun decode-term-string (string %term-string &optional (length (length string)))

229

(declare (type simple-string string)

230

(type rdfcache::foreign-pointer %term-string)

231

(optimize (speed 3) (safety 0)))

232

(dotimes (term-value-pos length)

233

(declare (type fixnum term-value-pos))

234

(let ((term-value-chr (rdfcache::%%utf8-get-char %term-string)))

235

(declare (type fixnum term-value-chr))

236

(setf (char string term-value-pos) (code-char term-value-chr)))

237

(setq %term-string (rdfcache::%%utf8-next-char %term-string))))

238

239

(defun call-with-term-string (op %term-string)

240

(declare (type cffi:foreign-pointer %term-string))

241

(let* ((term-value-len (rdfcache::%%utf8-get-length %term-string))

242

(string (make-string term-value-len)))

243

(declare (type fixnum term-value-len)

244

(type simple-string string)

245

(dynamic-extent string))

246

(decode-term-string string %term-string term-value-len)

247

(funcall op string)))

248

249

; decoding via cffi

250

(defun call-with-term-string (op %term-string)

251

(declare (type rdfcache::foreign-pointer %term-string))

252

(let ((string (cffi:foreign-string-to-lisp %term-string)))

253

(funcall op string))))

254

255

 (defmacro with-term-attributes ((term-type-var term-value-var term-language-var term-datatype-var) term &body body)

256

(let ((body-op (gensym "BODY-")))

257

`(rdfcache::with-checked-pointer (,term)

258

(let* ((,term-type-var (cffi:foreign-enum-value 'rdfcache::term-type

259

                                                          (cffi:foreign-slot-value ,term 'rdfcache::term 'rdfcache::type)))

260

(.term-value-ptr. (cffi:foreign-slot-value ,term 'rdfcache::term 'rdfcache::value))

261

               (.term-language-ptr. (cffi:foreign-slot-value ,term 'rdfcache::term 'rdfcache::language))

262

               (.term-datatype-ptr. (cffi:foreign-slot-value ,term 'rdfcache::term 'rdfcache::datatype)))

263

(flet ((,body-op (,term-type-var ,term-value-var ,term-language-var ,term-datatype-var)

264

,@body))

265

(case ,term-type-var

266

((:none 0)

267

(,body-op :none nil nil nil))

268

(t (with-term-string (,term-value-var .term-value-ptr.)

269

                   (cond ((and .term-language-ptr. (not (cffi:null-pointer-p .term-language-ptr.)))

270

(with-term-string (,term-language-var .term-language-ptr.)

271

                            (,body-op ,term-type-var ,term-value-var ,term-language-var nil)))

272

                         ((and .term-datatype-ptr. (not (cffi:null-pointer-p .term-datatype-ptr.)))

273

(with-term-string (,term-datatype-var .term-datatype-ptr.)

274

                            (,body-op ,term-type-var ,term-value-var nil ,term-datatype-var)))

275

(t

276

(,body-op ,term-type-var ,term-value-var nil nil)))))))))))

277

278

(defmacro with-task ((variable &rest args) &body body)

279

(let ((op (gensym)))

280

`(flet ((,op (,variable)

281

(declare (ignorable ,variable))

282

,@body))

283

(declare (dynamic-extent #',op))

284

(call-with-task #',op ,@args))))

285

286

287

(defmacro with-task-environment ((&key (query '*query*) (task query) normal-disposition abnormal-disposition)

288

&body body)

289

   "Bind the given query instance to the dynamic *query* variable, access and bind it's state variables,

290

and execute the body in this dynamic context."

291

(let ((op (gensym)))

292

`(flet ((,op () ,@body))

293

(declare (dynamic-extent #',op))

294

(call-with-task-environment #',op ,task

295

                                    ,@(when normal-disposition `(:normal-disposition ,normal-disposition))

296

                                    ,@(when abnormal-disposition `(:abnormal-disposition ,abnormal-disposition))))))

297

298

299

;;; foreign data accessors

300

301

(deftype foreign-array (element-type dimensions)

302

"declare the type and dimensions for a foreign array. these serve documentation purposes

303

only in those runtimes which promote the type to some standard type."

304

(declare (ignore element-type dimensions))

305

'cffi:foreign-pointer)

306

307

308

(define-declaration foreign-type (declaration &optional env)

309

"Support declaration information specific to foreign types beyond the

310

external pointer type available as the standard type declaraton.

311

In particular, a the foreign-array type includes the dimensions and the

312

element type."

313

314

(destructuring-bind (tag type . variables) declaration

315

(let ((old (when env (declaration-information tag env))))

316

(values :declare `(,tag (,type . ,variables)

317

. ,old)))))

318

319

320

(defun foreign-type-declaration (variable env)

321

(let ((declarations (declaration-information 'foreign-type env)))

322

(loop for (type . variables) in declarations

323

when (member variable variables)

324

return type

325

finally (error "foreign type is not defined: ~s: ~s" variable env))))

326

327

(eval-when (:compile-toplevel :load-toplevel :execute)

328

(defun array-row-major-index-form (dimensions &rest subscripts)

329

`(+ ,@(maplist (lambda (s d)

330

(if (cdr d)

331

                        `(* (the fixnum ,(car s)) ,(if (cddr d) (apply #'* (cdr d)) (second d)))

332

`(the fixnum ,(car s))))

333

subscripts

334

dimensions))))

335

 ;; (array-row-major-index-form '(* 3 4) 1 2 3) => (+ (* (THE FIXNUM 1) 12) (* (THE FIXNUM 2) 4) (THE FIXNUM 3))

336

337

(defmacro foreign-array-ref (pointer-variable &rest subscripts &environment env)

338

"rewrite the multi-dimensional foreign array reference to a foreign vector reference given the

339

base pointer and the subscripts."

340

(macroexpand-foreign-array-ref pointer-variable subscripts env))

341

342

(defun macroexpand-foreign-array-ref (pointer-variable subscripts env)

343

(let ((declaration (foreign-type-declaration pointer-variable env)))

344

(assert (typep declaration '(cons (eql foreign-array))) ()

345

             "variable not declared to be a foreign array: ~s : ~s : ~s" pointer-variable declaration env)

346

(destructuring-bind (type element-type dimensions) declaration

347

(declare (ignore type))

348

`(,+matrix-accessor+ (the sb-sys:system-area-pointer ,pointer-variable)

349

(the fixnum (* ,(cffi:foreign-type-size element-type)

350

                                           ,(apply #'array-row-major-index-form dimensions subscripts)))))))

351

352

353

(define-setf-expander foreign-array-ref (pointer-variable &rest subscripts &environment env)

354

(let ((declaration (foreign-type-declaration pointer-variable env)))

355

(assert (typep declaration '(cons (eql foreign-array))) ()

356

             "variable not declared to be a foreign array: ~s : ~s" pointer-variable declaration)

357

358

(destructuring-bind (type element-type dimensions) declaration

359

(declare (ignore type))

360

(let ((pointer-tmp (gensym))

361

(offset-tmp (gensym))

362

(value-tmp (gensym)))

363

(values (list pointer-tmp offset-tmp)

364

(list `(the sb-sys:system-area-pointer ,pointer-variable)

365

`(the fixnum (* ,(cffi:foreign-type-size element-type)

366

                                       ,(apply #'array-row-major-index-form dimensions subscripts))))

367

(list value-tmp)

368

`(locally (declare (type sb-sys:system-area-pointer ,pointer-tmp)

369

(type fixnum ,offset-tmp))

370

(setf (,+matrix-accessor+ ,pointer-tmp ,offset-tmp) ,value-tmp))

371

`(,+matrix-accessor+ ,pointer-tmp ,offset-tmp))))))

372

373

374

(define-setf-expander foreign-quad-ref (pointer-variable &rest subscripts &environment env)

375

(multiple-value-bind (scope bound-p type-info)

376

(variable-information pointer-variable env)

377

(declare (ignore scope))

378

(assert (and bound-p (eq (rest (assoc 'type type-info)) 'SB-SYS:SYSTEM-AREA-POINTER)) ()

379

"variable not declared to be a foreign pointer: ~s : ~s" pointer-variable env)

380

(let ((pointer-tmp (gensym))

381

(offset-tmp (gensym))

382

(value-tmp (gensym))

383

(dimensions '(* 4)))

384

(values (list pointer-tmp offset-tmp)

385

(list `(the sb-sys:system-area-pointer ,pointer-variable)

386

`(the fixnum (* ,(cffi:foreign-type-size +MATRIX-ELEMENT-TYPE+)

387

                                     ,(apply #'array-row-major-index-form dimensions subscripts))))

388

(list value-tmp)

389

`(locally (declare (type sb-sys:system-area-pointer ,pointer-tmp)

390

(type fixnum ,offset-tmp))

391

(setf (,+matrix-accessor+ ,pointer-tmp ,offset-tmp) ,value-tmp))

392

`(,+matrix-accessor+ ,pointer-tmp ,offset-tmp)))))

393

394

395

(defun named-term-number-object (term-number name)

396

(if (= term-number +null-term-id+)

397

(spocq:make-unbound-variable name)

398

(term-number-object term-number)))

399

400

(defmacro foreign-array-named-object-ref (name pointer-variable &rest subscripts)

401

"Return a reference to a foreign field array as a lisp object. The mapping delegates to rdfcache's

402

construction/caching mechanism except in the case of a null term, which is recognized here mapped to

403

an unbound variable instance. NB. the instance must be returned as that acts as a quasi-first-class

404

value for sort predicates."

405

406

`(named-term-number-object (foreign-array-ref ,pointer-variable ,@subscripts)

407

',name))

408

409

 #+(or)                                  ; fails because the declarations get lost

410

(defsetf foreign-array-named-object-ref (name pointer-variable &rest subscripts) (value)

411

(declare (ignore name)) ; needed for symmetry with the access form

412

`(setf (foreign-array-ref ,pointer-variable ,@subscripts)

413

(object-term-number ,value)))

414

415

416

(define-setf-expander foreign-array-named-object-ref (name pointer-variable &rest subscripts &environment env)

417

(let ((declaration (foreign-type-declaration pointer-variable env)))

418

(assert (typep declaration '(cons (eql foreign-array))) ()

419

             "variable not declared to be a foreign array: ~s : ~s" pointer-variable declaration)

420

421

(destructuring-bind (type element-type dimensions) declaration

422

(declare (ignore type))

423

(let ((pointer-tmp (gensym))

424

(offset-tmp (gensym))

425

(value-tmp (gensym)))

426

(values (list pointer-tmp offset-tmp)

427

(list `(the sb-sys:system-area-pointer ,pointer-variable)

428

`(the fixnum (* ,(cffi:foreign-type-size element-type)

429

                                       ,(apply #'array-row-major-index-form dimensions subscripts))))

430

(list value-tmp)

431

`(locally (declare (type sb-sys:system-area-pointer ,pointer-tmp)

432

(type fixnum ,offset-tmp))

433

(setf (,+matrix-accessor+ ,pointer-tmp ,offset-tmp)

434

(object-term-number ,value-tmp)))

435

`(named-term-number-object (,+matrix-accessor+ ,pointer-tmp ,offset-tmp)

436

,name))))))

437

438

439

440

;;;

441

;;; macros

442

443

(defmacro with-term-string ((string %term-string) &body body)

444

"Bind the STRING variable to the heap representation of the given exteral %TERM-STRING"

445

(let ((op (gensym)))

446

`(flet ((,op (,string)

447

(declare (dynamic-extent ,string))

448

,@body))

449

(declare (dynamic-extent #',op))

450

(call-with-term-string #',op ,%term-string))))

451

452

(defmacro with-transaction ((&rest args

453

&key (transaction '(task-transaction *task*))

454

(repository '(task-revision *task*))

455

(revision repository)

456

normal-disposition abnormal-disposition)

457

&body body)

458

"Wrap the body in a dynamic context which opens and optionaly closes a transaction for the

459

given repository. It uses a transaction instance which is created lazily for the current task

460

and the task's abstract repository instance.

461

It dynamically binds the transaction to *transaction* and execute the body."

462

463

(declare (ignore normal-disposition abnormal-disposition))

464

(setf args (copy-list args))

465

(remf args :transaction)

466

(remf args :revision)

467

(remf args :repository)

468

(let ((op (gensym "transaction-op-")))

469

`(flet ((,op (*transaction*) ,@body))

470

(declare (dynamic-extent #',op))

471

(unwind-protect (call-with-revision-transaction #',op ,revision ,transaction ,@args)

472

(setq *transaction* nil)))))

473

474

(defmacro with-open-repository ((repository-id &rest args) &rest body)

475

   "Instantiate the given repository, bind its latest revision dynamically to *repository* and execute within a

476

transaction based on that revision."

477

(when (and (find :read-only args) (not (find :read-only-p args)))

478

(warn "with-open-repository requires :read-only-p")

479

(setf args (copy-list args))

480

(setf (getf args :read-only-p) (getf args :read-only))

481

(remf args :read-only))

482

(let ((op (gensym "repository-op")))

483

`(flet ((,op (*repository*) ,@body))

484

(declare (dynamic-extent #',op))

485

(call-with-open-repository #',op ,repository-id ,@args))))

486

487

(defmacro with-repository (repository &body body)

488

`(let ((*repository* ,repository))

489

,@body))

490

491

(defmacro with-open-transaction ((repository-id &rest args

492

&key

493

api-key id revision-id

494

operation

495

if-does-not-exist

496

normal-disposition abnormal-disposition

497

                                   (read-only-p (not (eq normal-disposition :commit)) rop-s)

498

serialize)

499

&rest body)

500

"Create just an autonomous transaction for the given repository -optionally specific as

501

to revision, bind it dynamically to *transaction* and execute the body."

502

(declare (ignore api-key id revision-id operation if-does-not-exist abnormal-disposition serialize))

503

(let ((op (gensym "transaction-op")))

504

(unless rop-s (setf args (list* :read-only-p read-only-p args)))

505

`(flet ((,op (*transaction*) ,@body))

506

(declare (dynamic-extent #',op))

507

(unwind-protect (call-with-open-transaction #',op ,repository-id ,@args)

508

(setq *transaction* nil)))))

509

510

511

(defmacro print-lexical-frame (&optional name &environment env)

512

(let ((vars (remove nil (mapcar #'first (sb-c::lexenv-vars env)))))

513

`(format *trace-output* "~%~@[~a: ~]~s~%"

514

',name

515

(list ,@(loop for var in vars

516

for var-name = (symbol-name var)

517

when (eq (find-symbol var-name *package*) var)

518

collect `(list ',var ,var))))))

519

520

;;; class hierarchy manipulation to get abstract iri class

521

;;; both the targets are just standard-object dsp[acializations, so pushed is fine

522

523

(defgeneric interpose-superclass (add-class amqp-class)

524

(:method ((add-class symbol) (class t))

525

(interpose-superclass (find-class add-class) class))

526

(:method ((add-class t) (class symbol))

527

(interpose-superclass add-class (find-class class)))

528

(:method ((add-class class) (class class))

529

(let ((existing-supers (c2mop:class-direct-superclasses class)))

530

(unless (find add-class existing-supers)

531

(reinitialize-instance class

532

                                :direct-superclasses (cons add-class existing-supers))))

533

class))

534

535

(defgeneric null-sequence-p (object)

536

(:method ((object null)) t)

537

(:method ((object sequence)) (zerop (length object)))

538

(:method ((object t)) nil))

539

540

(defun class-designator-p (object)

541

(when (and object (symbolp object) (find-class object nil))

542

t))

543

544

545

;;; iri/uri operators

546

547

(defgeneric iri-p (object)

548

(:documentation "Return true iff the given OBJECT represents an IRI.

549

The implementation distinguishes the self-evident classes (URI and UUID) by type and

550

classifies symbols according to whether their package is registered as a vocabaulary.

551

All other types are non-iri. Requires transparent arguments.")

552

(:method ((object t)) nil)

553

(:method ((object symbol)) (when (get-symbol-uri-namestring object) t))

554

(:method ((object spocq:iri)) t)

555

(:method ((object null)) nil))

556

557

(deftype iri () '(satisfies iri-p))

558

(deftype iri-designator () '(or iri string))

559

560

(defgeneric http-url-p (object)

561

(:documentation "Return true iff the given OBJECT represents an http url.

562

The implementation distinguishes the self-evident classes (URI and UUID) by type and

563

classifies symbols according to whether their package is registered as a vocabaulary.

564

All other types are non-iri. Requires transparent arguments.")

565

(:method ((object t)) nil)

566

(:method ((object symbol)) (http-url-p (iri-lexical-form object)))

567

(:method ((object string))

568

(is-http-url object))

569

(:method ((object spocq:http-url)) t)

570

(:method ((object null)) nil))

571

572

(defgeneric file-url-p (object)

573

(:documentation "Return true iff the given OBJECT represents an http url.

574

The implementation distinguishes the self-evident classes (URI and UUID) by type and

575

classifies symbols according to whether their package is registered as a vocabaulary.

576

All other types are non-iri. Requires transparent arguments.")

577

(:method ((object t)) nil)

578

(:method ((object symbol)) (file-url-p (iri-lexical-form object)))

579

(:method ((object string))

580

(is-file-url-namestring object))

581

(:method ((object spocq:file-url)) t)

582

(:method ((object null)) nil))

583

584

(defgeneric is-absolute-iri (string)

585

(:method ((datum null))

586

nil)

587

(:method ((datum t))

588

(is-absolute-iri-string (iri-lexical-form datum)))

589

(:method ((lexical-form string))

590

(is-absolute-iri-string lexical-form)))

591

592

(defun absolute-iri-p (object)

593

(and (iri-p object)

594

(is-absolute-iri (iri-lexical-form object))))

595

596

(deftype absolute-iri () '(satisfies absolute-iri-p))

597

598

(defun iri-package-p (package)

599

(when (member package *iri-packages*) t))

600

601

(defun format-iri (stream datatype &optional colon at)

602

(declare (ignore colon at))

603

(write-string (term-lexical-form datatype) stream))

604

605

(defgeneric cl-user::format-iri-url-encoded (stream iri &optional colon at)

606

(:method (stream (string string) &optional colon at)

607

(declare (ignore colon at))

608

(loop for c across string

609

for ci = (char-int c)

610

if (and (< ci 127)

611

(= 0 (sbit puri::*reserved-characters* ci)))

612

do (write-char c stream)

613

else do (multiple-value-bind (q r) (truncate ci 16)

614

(write-char #\% stream)

615

(write-char (elt puri::*escaped-encoding* q) stream)

616

(write-char (elt puri::*escaped-encoding* r) stream))))

617

(:method (stream (iri t) &optional colon at)

618

(declare (ignore colon at))

619

(cl-user::format-iri-url-encoded stream (iri-lexical-form iri))))

620

;;;(format nil "~/format-iri-url-encoded/" "(select * { }")

621

622

(defun url-encode (string)

623

(let ((result (make-array (length string) :element-type 'character :fill-pointer 0 :adjustable t)))

624

(loop for c across string

625

for ci = (char-int c)

626

if (and (< ci 127)

627

(/= ci #.(char-code #\newline)) ;; added

628

(/= ci #.(char-code #\')) ;; added

629

(= 0 (sbit puri::*reserved-characters* ci)))

630

do (vector-push-extend c result)

631

else do (multiple-value-bind (q r) (truncate ci 16)

632

(vector-push-extend #\% result)

633

(vector-push-extend (elt puri::*escaped-encoding* q) result)

634

(vector-push-extend (elt puri::*escaped-encoding* r) result)))

635

result))

636

#+(or) ;; alternative definition

637

(defun url-rewrite:url-encode (string)

638

"URL-encode a string."

639

(with-output-to-string (s)

640

(loop for c across string

641

do (cond ((or (char<= #\0 c #\9)

642

(char<= #\a c #\z)

643

(char<= #\A c #\Z)

644

(find c "$-_.!*'()," :test #'char=))

645

(write-char c s))

646

((char= c #\Space)

647

(write-char #\+ s))

648

(t (format s "%~2,'0x" (char-code c)))))))

649

650

(defun url-decode (string &key (start 0) (end (length string)))

651

(let ((from-i start)

652

         (decoded-string (make-array (length string) :element-type 'character :adjustable t :fill-pointer 0)))

653

(loop (when (>= from-i end) (return))

654

(let ((char (char string from-i)))

655

(cond ((eql char #\%)

656

                    (vector-push-extend (code-char (parse-integer string :start (+ from-i 1) :end (+ from-i 3) :radix 16))

657

decoded-string)

658

(incf from-i 3))

659

((eql char #\+)

660

(vector-push-extend #\space decoded-string)

661

(incf from-i))

662

(t

663

(vector-push-extend char decoded-string)

664

(incf from-i)))))

665

decoded-string))

666

667

(defgeneric iri-namespace (iri)

668

(:method ((iri symbol))

669

(when (symbol-uri-namestring iri)

670

(package-name (symbol-package iri))))

671

(:method ((iri spocq:iri))

672

(iri-namespace (spocq:iri-lexical-form iri)))

673

(:method ((iri puri:uri))

674

(case (puri:uri-scheme iri)

675

((:http :https)

676

(if (puri:uri-fragment iri)

677

(format nil "http://~a~@[~a~]#"

678

(puri:uri-host iri)

679

(puri:uri-path iri))

680

(let* ((path (rest (puri:uri-parsed-path iri))))

681

(format nil "http://~a/~{~a/~}"

682

(puri:uri-host iri)

683

(butlast path)))))

684

(:urn

685

(format nil "urn:~a:"

686

(puri:urn-nid iri)))))

687

(:method ((lexical-form string))

688

(iri-namespace (puri:uri lexical-form))))

689

;;; (iri-namespace "http://dydra.com#asdf")

690

;;; (iri-namespace "http://dydra.com/asdf")

691

;;; (iri-namespace "http://dydra.com/asdf/qwer")

692

;;; (iri-namespace "http://dydra.com/asdf/qwer/")

693

;;; (iri-namespace "http://dydra.com/asdf/qwer/#yxcv")

694

695

(defgeneric iri-local-part (iri)

696

(:method ((iri symbol))

697

(symbol-name iri))

698

(:method ((iri spocq:iri))

699

(iri-local-part (spocq:iri-lexical-form iri)))

700

(:method ((iri puri:uri))

701

(case (puri:uri-scheme iri)

702

((:http :https)

703

(or (puri:uri-fragment iri)

704

(let* ((path (rest (puri:uri-parsed-path iri)))

705

(leaf (first (last path))))

706

(when (plusp (length leaf)) leaf))))

707

(:urn

708

(puri:urn-nss iri))))

709

(:method ((lexical-form string))

710

(when (char= #\< (char lexical-form 0))

711

(setf lexical-form (subseq lexical-form 1 (1- (length lexical-form)))))

712

(iri-local-part (puri:uri lexical-form)))

713

(:method ((node spocq:blank-node))

714

(spocq:blank-node-label node)))

715

716

;;; (iri-local-part "http://dydra.com#asdf")

717

;;; (iri-local-part "http://dydra.com/asdf")

718

;;; (iri-local-part "http://dydra.com/asdf/qwer")

719

;;; (iri-local-part "http://dydra.com/asdf/qwer/")

720

;;; (iri-local-part "http://dydra.com/asdf/qwer/#yxcv")

721

722

(defgeneric iri-qname (iri)

723

(:method ((iri symbol))

724

(let ((namestring (symbol-uri-namestring iri)))

725

(if namestring

726

(iri-qname namestring)

727

(concatenate 'string (package-name (symbol-package iri)) ":" (symbol-name iri)))))

728

(:method ((iri t))

729

(iri-qname (puri:uri iri)))

730

(:method ((lexical-form string))

731

(when (char= #\< (char lexical-form 0))

732

(setf lexical-form (subseq lexical-form 1 (1- (length lexical-form)))))

733

(iri-qname (puri:uri lexical-form)))

734

(:method ((iri puri:uri))

735

(let* ((namespace (iri-namespace iri))

736

(local-part (iri-local-part iri))

737

(binding (rassoc namespace *namespace-bindings* :test #'equal)))

738

(when binding

739

(concatenate 'string (first binding) ":" local-part)))))

740

741

(defgeneric iri-label (iri)

742

(:method ((iri symbol))

743

(let ((namestring (symbol-uri-namestring iri)))

744

(if namestring

745

(iri-label (puri:uri namestring))

746

(symbol-name iri))))

747

(:method ((iri spocq:iri))

748

(iri-label (puri:uri (spocq:iri-lexical-form iri))))

749

(:method ((uri puri:uri))

750

(case (puri:uri-scheme uri)

751

((:http :https)

752

(cond ((iri-qname uri))

753

((puri:uri-path uri)

754

(if (puri:uri-fragment uri)

755

(concatenate 'string (puri:uri-path uri) "#" (puri:uri-fragment uri))

756

(puri:uri-path uri)))

757

(t

758

(puri:uri-host uri))))

759

(:urn

760

(puri:urn-nss uri))))

761

(:method ((lexical-form string))

762

(when (char= #\< (char lexical-form 0))

763

(setf lexical-form (subseq lexical-form 1 (1- (length lexical-form)))))

764

(iri-label (puri:uri lexical-form)))

765

(:method ((node spocq:blank-node))

766

(spocq:blank-node-label node)))

767

768

;;; (iri-label "http://dydra.com#asdf")

769

;;; (iri-label "http://dydra.com/asdf")

770

;;; (iri-label "http://dydra.com/asdf/qwer")

771

;;; (iri-label "http://dydra.com/asdf/qwer/")

772

;;; (iri-label "http://dydra.com/asdf/qwer/#yxcv")

773

774

(defparameter *iri-authority-scanner*

775

(cl-ppcre:create-scanner

776

'(:sequence "http" (:greedy-repetition 0 1 #\s) "://"

777

(:register (:GREEDY-REPETITION 0 NIL (:INVERTED-CHAR-CLASS #\/)))

778

(:GREEDY-REPETITION 0 NIL :EVERYTHING))))

779

;;; (cl-ppcre:scan-to-strings *iri-authority-scanner* "<http://asdf/>")

780

781

(defgeneric iri-authority (iri)

782

(:method ((iri symbol))

783

(let ((namestring (symbol-uri-namestring iri)))

784

(when namestring

785

(iri-authority (puri:uri namestring))

786

)))

787

(:method ((iri spocq:iri))

788

(iri-authority (spocq:iri-lexical-form iri)))

789

(:method ((uri puri:uri))

790

(PURI:URI-AUTHORITY uri))

791

(:method ((lexical-form string))

792

(when (char= #\< (char lexical-form 0))

793

(setf lexical-form (subseq lexical-form 1 (1- (length lexical-form)))))

794

(elt (nth-value 1 (cl-ppcre:scan-to-strings *iri-authority-scanner* lexical-form))

795

0)))

796

;;; (iri-authority "<http://asdf/>")

797

798

(defgeneric iri-keyword (iri)

799

(:method ((iri symbol))

800

(or (get iri 'iri-keyword)

801

(setf (get iri 'iri-keyword) (cons-symbol :keyword (symbol-name iri)))))

802

(:method ((iri t))

803

(cons-symbol :keyword (iri-label iri))))

804

805

;;; extend the puri library to handle url query arguments

806

(defgeneric iri-parsed-query (iri)

807

(:method ((iri puri:uri))

808

(or (getf (puri:uri-plist iri) :parsed-query)

809

(setf (getf (puri:uri-plist iri) :parsed-query)

810

(loop for (key value) on (split-string (puri:uri-query iri) "&=")

811

append (list (intern (string-upcase key) :keyword) (url-decode value)))))))

812

813

(defgeneric (setf iri-parsed-query) (parsed iri)

814

(:method ((parsed list) (iri puri:uri))

815

(setf (getf (puri:uri-plist iri) :parsed-query) parsed)))

816

817

(defgeneric iri-query-argument (iri key)

818

(:method ((iri puri:uri) key)

819

(getf (iri-parsed-query iri) key)))

820

821

(defgeneric (setf iri-query-argument) (value iri key)

822

(:method (value (iri puri:uri) key)

823

(let ((parsed-query (iri-parsed-query iri)))

824

(if value

825

(setf (getf parsed-query key) value)

826

(remf parsed-query key))

827

(setf (iri-parsed-query iri) parsed-query)

828

(setf (slot-value iri 'puri::query) (format nil "~{~(~a~)=~a~^&~}" parsed-query))

829

(setf (slot-value iri 'puri::string) nil)

830

value)))

831

832

833

(defun symbol-variable (symbol)

834

(or (get symbol 'spocq.i::variable)

835

(setf (get symbol 'spocq.i::variable) (make-variable (symbol-name symbol)))))

836

837

838

839

(defmacro incf-stat (variable &optional amount)

840

"provides a distinguished operator for statistic counters."

841

`(incf ,variable ,@(when amount (list amount))))

842

843

(defun remove-properties (properties plist)

844

(loop for (property value) on plist by #'cddr

845

unless (member property properties)

846

nconc (list property value)))

847

848

(defun copy-properties (properties plist)

849

(loop for (property value) on plist by #'cddr

850

when (member property properties)

851

nconc (list property value)))

852

#|

853

;;; unused for solution pages

854

(defmacro collect-solutions ((collector &key (predicate nil) (finally 'rest) (name nil)) &rest body)

855

(let ((list (gensym "LIST-"))

856

(end (gensym "END-")))

857

`(let* ((,list (list nil)) (,end ,list))

858

(block ,name

859

(flet ((,collector (datum)

860

,(case predicate

861

((nil) `(setf (rest ,end) (list datum) ,end (rest ,end)))

862

                      (t `(when (funcall ,predicate datum) (setf (rest ,end) (list datum) ,end (rest ,end)))))))

863

,@body))

864

(prog1 (,finally ,list)

865

(setf ,list nil ,end nil)))))

866

867

#+digitool

868

(setf (ccl:assq 'collect-solutions ccl:*fred-special-indent-alist*) 1)

869

|#

870

871

872

(defun compress-solution-field (field &optional (variables (loop for (variable nil) on (first field)

873

                                                                  by #'cddr

874

                                                                  collect variable)))

875

(let ((filter (spocq-compile `(lambda (solution)

876

                                   (flet ((rewrite (&key ,@(mapcar #'(lambda (var)

877

                                                                       `((,var ,var)

878

                                                                         (load-time-value (spocq:make-unbound-variable ',var))))

879

                                                                   variables)

880

                                                         &allow-other-keys)

881

                                            (declare (ignorable ,@variables))

882

(list ,@variables)))

883

(declare (dynamic-extent #'rewrite))

884

(apply #'rewrite solution))))))

885

(cons variables (mapcar filter field))))

886

887

888

(defun algebra-thread-count ()

889

"Return the nimber of threads to be created which reducing partitionable algebra operations.

890

Ultimately should reflect the core count. Provisionally just 2."

891

*algebra-thread-count*)

892

893

894

;;; fields and terms

895

896

(defstruct abstract-solution-field )

897

(defstruct (solution-field (:include abstract-solution-field))

898

;; A list of the variable names for the field.

899

(dimensions () :type list)

900

(sort-dimensions () :type list)

901

(solutions )

902

   (row-index 0 :type fixnum)            ; currrent iteration position within a page to read or write

903

(row-count 0 :type fixnum) ; length of the current data array or matrix

904

   (length 0 :type fixnum)               ; total field length, if page-streamed, the cumulative length

905

                                         ; if static, equal to the row count

906

   (count 0 :type fixnum)                ; caches the expected field size, eg. based on selectivity and repository size

907

(state :closed :type (member :closed :input :output))

908

)

909

910

(defstruct (array-solution-field (:include solution-field (solutions #() :type array)))

911

"A solution-field comprises a dimension list and the solution array / array vector"

912

)

913

914

(defstruct (symbolic-solution-field (:include solution-field (solutions () :type list)))

915

"A solution-field comprises a dimension list and a 2-level solution list"

916

)

917

918

(defstruct (list-solution-field (:include solution-field (solutions () :type list)))

919

"A solution-field comprises a dimension list and a 2-level solution list"

920

)

921

922

(defstruct (null-solution-field (:include solution-field)))

923

924

925

(defun solution-field-initialize (field &rest args)

926

(apply #'initialize-solution-field field args))

927

928

(defun initialize-result-field (field &rest args)

929

(apply #'initialize-solution-field field args))

930

931

(defgeneric initialize-solution-field (field &key dimensions sort-dimensions row-count data)

932

)

933

934

(defun result-field-dimensions (field)

935

(when field

936

(solution-field-dimensions field)))

937

938

(defgeneric solution-field-sort (field order)

939

(:documentation "sort the field based on term number values given a row prcedence list"))

940

941

942

(defgeneric set-solution-field-solutions (field solutions)

943

)

944

945

946

(defgeneric solution-field-concatenate (field1 field2)

947

(:method ((field1 t) (field2 null))

948

field1)

949

(:method ((field1 null) (field2 t))

950

field2))

951

952

953

(defmethod print-object ((object solution-field) (stream t))

954

(_print-unreadable-object (object stream :type t :identity t)

955

(format stream "~s.~s ~s/~s ~s@~a"

956

(solution-field-dimensions object)

957

(solution-field-sort-dimensions object)

958

(solution-field-row-index object)

959

(solution-field-row-count object)

960

(solution-field-length object)

961

(solution-field-state object))))

962

963

964

965

(defgeneric solution-field-solutions-row-count (field)

966

(:method ((field list)) (length field))

967

(:method ((field array)) (array-dimension field 0))

968

   (:method ((field vector)) (reduce  #'+ field :key #'(lambda (page) (array-dimension page 0)) :initial-value 0))

969

#+sbcl (:method ((field sb-sys:system-area-pointer))

970

(if (cffi:null-pointer-p field)

971

0

972

(rdfcache:matrix-row-count field)))

973

(:method ((field solution-field))

974

(solution-field-row-count (solution-field-solutions field))))

975

976

(defgeneric solution-field-column-count (field)

977

(:method ((field list)) (length (first field)))

978

(:method ((field array)) (array-dimension field 1))

979

(:method ((field symbolic-solution-field))

980

(length (first (solution-field-solutions field))))

981

(:method ((field array-solution-field))

982

(let ((solutions (solution-field-solutions field)))

983

(typecase solutions

984

(null 0)

985

(sequence (array-dimension (elt solutions 0) 1))

986

(array (array-dimension solutions 1))

987

(t 0)))))

988

989

(defun solution-field-solutions-column-count (field)

990

(solution-field-column-count field))

991

992

(defgeneric filter-solution-field (field predicate)

993

(:method ((field list) (predicate function))

994

(loop for solution in field

995

when (every predicate solution)

996

collect solution)))

997

998

(defmacro trace-matrix (&rest args)

999

(if *matrix-trace-output*

1000

`(let ((*print-pretty* nil))

1001

(fresh-line *matrix-trace-output*)

1002

(format *matrix-trace-output* ,@args)

1003

(terpri *matrix-trace-output*)

1004

(finish-output *matrix-trace-output*)

1005

)

1006

(values)))

1007

1008

;;; although this is a good logical location to interpose a thread split,

1009

;;; the reduction mechanism means that it would alread have to have happened - otherwise

1010

;;; the field is already complete before it is returned to be used as an argument.

1011

;;; in the always-threaded implementation, this was achievend by generators (the

1012

;;; logical equivalent of volcano's xchg). in this call structure they would still need to

1013

;;; be interposed prospectively.

1014

;;; ideally, the thread should be introduced exactly at the point where a page overflow

1015

;;; happens. up to that point the reduction process sufficis, after that the two steps

1016

;;; should proceed asynchronously.

1017

;;; the most flexible mechaism ist to generalize the reified algebra operators which implement the bgp

1018

;;; processing to cover the entire operator complement and specialize the spocq.e operators to

1019

;;; combine bgp operations either in-line or deferred to threads and to implement the combination

1020

;;; itself inline or as a deferred reified operation.

1021

;;; this delays the htreading decision to the latest possible point based on the cardinality of the

1022

;;; inputs.

1023

;;; rather than dedicate an operator to this which the planner needs to insert, it would be best

1024

;;; to implement it as an around method on either generic processing function or

1025

;;; add a method to the respective algebraic operators.

1026

1027

(defun call-with-input-fields (function &rest fields)

1028

"Given FUNCTION, a function of no arguments, and FIELDS, the fields upon which to operate,

1029

reset the fields to an initial input state, call the function, and

1030

clean up by releasing the fields' resources as indicated.

1031

VALUES : t : as returned by the function"

1032

1033

(loop for field in fields

1034

unless (eq (solution-field-state field) :input)

1035

do (progn (setf (solution-field-row-index field) 0

1036

(solution-field-state field) :input)

1037

(trace-matrix "input-field: ~s.~s~%~{ ~s~%~}"

1038

(solution-field-dimensions field)

1039

(solution-field-sort-dimensions field)

1040

(term-value-field field))))

1041

(unwind-protect (funcall function)

1042

(loop for field in fields

1043

do (progn (incf-stat *solutions-processed* (solution-field-length field))

1044

(release-field-data field)))))

1045

1046

(defun call-with-result-field (function result-field &rest args)

1047

(unless (eq (solution-field-state result-field) :output)

1048

(apply #'initialize-result-field result-field args)

1049

(setf (solution-field-state result-field) :output))

1050

(unwind-protect (funcall function)

1051

(trace-matrix "result-field: ~s.~s~%~{ ~s~%~}"

1052

(solution-field-dimensions result-field)

1053

(solution-field-sort-dimensions result-field)

1054

(term-value-field result-field))

1055

(incf-stat *solutions-constructed* (solution-field-length result-field))))

1056

1057

(defgeneric release-field-data (field)

1058

)

1059

1060

1061

(defmacro with-input-fields ((&rest fields) &body body)

1062

(let ((op (gensym "field-op-")))

1063

`(flet ((,op () ,@body))

1064

(declare (dynamic-extent #',op))

1065

(call-with-input-fields #',op ,@fields))))

1066

1067

(defmacro with-result-field ((field &rest arglist) &body body)

1068

(let ((op (gensym "field-op-")))

1069

`(flet ((,op () ,@body))

1070

(declare (dynamic-extent #',op))

1071

(call-with-result-field #',op ,field ,@arglist))))

1072

1073

;;; generators

1074

1075

(defstruct (abstract-field-generator (:include solution-field))

1076

"An abstract-generator adds an activation function and a solution channel to a solution field.

1077

If the channle is present, then the generatin process is active. Otherwise the activation

1078

function is called with a continuation to accept the generated fields.

1079

The channel contains either an already partially materialized field from a thread which

1080

is generating the result, or a complete result from a completed reduction operation

1081

or bgp pattern match."

1082

(operator nil)

1083

(expression nil)

1084

(channel nil)

1085

(constituents nil)

1086

(concrete-operator nil))

1087

1088

(defmethod print-object ((object abstract-field-generator) (stream t))

1089

(_print-unreadable-object (object stream :type t :identity t)

1090

(format stream "~a x ~a~@[ ~a~]"

1091

(abstract-field-generator-operator object)

1092

(solution-field-dimensions object)

1093

(solution-field-sort-dimensions object))))

1094

1095

(defstruct (solution-generator (:include abstract-field-generator))

1096

)

1097

1098

(defstruct (leftjoin-solution-generator (:include solution-generator))

1099

"Add the explicit key-dimensions slot to record the initial combination

1100

distinct from the effective combined dimensions. This is used in subsequent

1101

leftjoins to limit keys to dimensions guaranteed to be bound."

1102

(key-dimensions () :type list))

1103

1104

(defgeneric solution-generator-key-dimensions (generator)

1105

(:documentation "Return those dimensions to include in a hash key for a

1106

join / leftjoin. In the leftjoin case, the result field retains this value

1107

rather than the combined dimensions as additional dimensions may not be

1108

bound in a given solution.")

1109

(:method ((generator solution-generator))

1110

(solution-generator-dimensions generator))

1111

(:method ((generator leftjoin-solution-generator))

1112

(leftjoin-solution-generator-key-dimensions generator)))

1113

1114

(defstruct (group-solution-generator (:include solution-generator))

1115

"Add group key bindings to the field description"

1116

(key-bindings () :type list))

1117

1118

(defgeneric solution-generator-key-bindings (generator)

1119

(:documentation "Return the bindings for grouping a field.")

1120

(:method ((generator solution-generator))

1121

())

1122

(:method ((generator group-solution-generator))

1123

(group-solution-generator-key-bindings generator)))

1124

1125

(defstruct (boolean-generator (:include abstract-field-generator))

1126

)

1127

1128

(defstruct (bgp-generator (:include solution-generator))

1129

(pattern nil)

1130

(pattern-function nil))

1131

1132

(defstruct (null-generator (:include solution-generator)))

1133

1134

1135

(defstruct (graph-generator (:include solution-generator))

1136

"A graph-generator generates the particular form of solution field which denotes a graph,

1137

and in which each solution denotes a statement in the graph. Ii is realized as triple-graph-generator

1138

and quad-graph-generator.")

1139

1140

(defstruct (triple-graph-generator (:include graph-generator))

1141

"A triple-graph-generator applies to construct and describe queries.

1142

The means, there are always three dimensions, (?s ?p ?o).")

1143

1144

(defstruct (quad-graph-generator (:include graph-generator))

1145

"A quad-graph-generator is not (yet) used.")

1146

1147

(defstruct (construct-generator (:include triple-graph-generator

1148

(operator 'spocq.a:|construct|)

1149

                                           (dimensions *construct-dimensions*))))

1150

1151

(defstruct (describe-generator (:include triple-graph-generator

1152

(operator 'spocq.a:|describe|)

1153

                                          (dimensions *describe-dimensions*))))

1154

1155

(defstruct (dependent-solution-generator (:include solution-generator))

1156

"A dependent generator expects to be a SIP target, to initiate its execution

1157

based on the passed solution and to emit the effectively merge-joined results."

1158

)

1159

1160

1161

(defgeneric copy-generator (generator &key dimensions expression)

1162

(:documentation "implements copy operation specific to generators, but with generic name.")

1163

(:method :around ((generator abstract-field-generator) &rest args

1164

&key (dimensions (solution-field-dimensions generator))

1165

(expression (abstract-field-generator-expression generator))

1166

(constituents (abstract-field-generator-constituents generator))

1167

(operator (abstract-field-generator-operator generator)))

1168

(apply #'call-next-method generator :dimensions dimensions :expression expression

1169

:constituents constituents

1170

:operator operator

1171

args))

1172

(:method ((generator boolean-generator) &rest args)

1173

(apply #'make-boolean-generator args))

1174

(:method ((generator solution-generator) &rest args)

1175

(apply #'make-solution-generator args))

1176

(:method ((generator bgp-generator) &rest args &key (pattern (bgp-generator-pattern generator))

1177

&allow-other-keys)

1178

(apply #'make-bgp-generator

1179

:pattern pattern

1180

args)))

1181

1182

(defgeneric solution-generator-patterns (generator)

1183

(:method ((generator bgp-generator))

1184

(list (bgp-generator-pattern generator)))

1185

(:method ((generator abstract-field-generator))

1186

(reduce #'append (abstract-field-generator-constituents generator)

1187

:key #'solution-generator-patterns)))

1188

1189

;;;

1190

1191

(defmethod print-generator-tree ((generator abstract-field-generator) &key (stream *trace-output*))

1192

(let* ((op (abstract-field-generator-operator generator))

1193

(channel (abstract-field-generator-channel generator))

1194

(*print-pretty* nil)

1195

(generator-level (if (boundp 'generator-level) (1+ (symbol-value 'generator-level)) 1)))

1196

(declare (special generator-level))

1197

(format stream "~&~vT~a :~a"

1198

(* 2 generator-level) op channel)

1199

(loop for constituent in (abstract-field-generator-constituents generator)

1200

do (print-generator-tree constituent :stream stream))))

1201

1202

1203

(defstruct version-map vector length)

1204

(defstruct (timestamp-map (:include version-map (vector nil :type vector))))

1205

(defstruct (ordinal-map (:include version-map)))

1206

(defstruct (foreign-ordinal-map (:include ordinal-map (vector nil :type cffi:foreign-pointer)))

1207

"Intended to contain a foreign ordinal vector and include the length")

1208

(defstruct (vector-ordinal-map (:include ordinal-map (vector nil :type vector)))

1209

"Intended to contain a heap ordinal vector and include the length")

1210

1211

1212

;;;

1213

;;; counters

1214

;;; packaged in structs to support sbcl thread-safe operators

1215

1216

(deftype atomic-index () #+sbcl 'sb-ext:word #-sbcl 'integer)

1217

1218

(defstruct (task-indices (:conc-name task-))

1219

(blank-node-index 0 :type atomic-index)

1220

(sequence-index 0 :type atomic-index)

1221

(variable-index 0 :type atomic-index))

1222

(setq *task-indices* (make-task-indices))

1223

1224

(defun next-blank-node-index ()

1225

#+sbcl (1+ (sb-ext:atomic-incf (task-blank-node-index *task-indices*)))

1226

#+lw (system:atomic-fixnum-incf (task-blank-node-index *task-indices*))

1227

#-(or lw sbcl) (incf (task-blank-node-index *task-indices*)))

1228

1229

(defun next-sequence-index ()

1230

#+sbcl (1+ (sb-ext:atomic-incf (task-sequence-index *task-indices*)))

1231

#+lw (system:atomic-fixnum-incf (task-sequence-index *task-indices*))

1232

#-(or lw sbcl) (incf (task-sequence-index *task-indices*)))

1233

1234

(defun next-variable-index ()

1235

#+sbcl (1+ (sb-ext:atomic-incf (task-variable-index *task-indices*)))

1236

#+lw (system:atomic-fixnum-incf (task-variable-index *task-indices*))

1237

#-(or lw sbcl) (incf (task-variable-index *task-indices*)))

1238

1239

1240

(defun construct-dimensions ()

1241

*construct-dimensions*)

1242

1243

(defun describe-dimensions ()

1244

*describe-dimensions*)

1245

1246

(defun union-dimensions (dimensions1 dimensions2)

1247

(sort (remove-duplicates (append dimensions1 dimensions2) :from-end t)

1248

#'string-lessp))

1249

1250

(defun intersect-dimensions (dimensions1 dimensions2)

1251

(sort (intersection dimensions1 dimensions2)

1252

#'string-lessp))

1253

1254

(defgeneric difference-dimensions (dimensions1 dimensions2)

1255

(:method ((dimensions1 list) (dimensions2 list))

1256

(sort (set-difference dimensions1 dimensions2)

1257

#'string-lessp))

1258

(:method ((dimensions1 vector) (dimensions2 t))

1259

(difference-dimensions (loop for x across dimensions1 collect x) dimensions2))

1260

(:method ((dimensions1 t) (dimensions2 vector))

1261

(difference-dimensions dimensions1 (loop for x across dimensions2 collect x))))

1262

1263

(defun join-dimensions (dimensions1 dimensions2)

1264

"given two dimension systems, return their intersection.

1265

allow for nil elements."

1266

(loop for dimension in dimensions1

1267

when (and dimension (member dimension dimensions2))

1268

collect dimension))

1269

1270

(defun join-result-dimensions (left &optional right)

1271

(flet ((undistinguished-not-context (variable)

1272

#+(or)(or (and (undistinguished-variable-p variable)

1273

(not (eq variable +context-variable+)))

1274

(null (symbol-package variable)))

1275

(null (symbol-package variable))))

1276

(declare (dynamic-extent #'undistinguished-not-context))

1277

(if right

1278

(loop with projected-left = (remove-if #'undistinguished-not-context left)

1279

for dimension in right

1280

unless (or (member dimension projected-left)

1281

(undistinguished-not-context dimension))

1282

collect dimension into projected-right

1283

finally (return (append projected-left projected-right)))

1284

(remove-if #'undistinguished-not-context left))))

1285

1286

(defun join-key-dimensions (left right)

1287

   ;; iff an undistinguished variable binds the context, then it is from a quad match and should be retained

1288

(flet ((undistinguished-not-context (variable)

1289

#+(or)(or (and (undistinguished-variable-p variable)

1290

(not (eq variable +context-variable+)))

1291

(null (symbol-package variable)))

1292

(null (symbol-package variable))))

1293

(declare (dynamic-extent #'undistinguished-not-context))

1294

(loop for dimension in left

1295

unless (undistinguished-not-context dimension)

1296

when (member dimension right)

1297

collect dimension)))

1298

1299

1300

(defun unit-table ()

1301

(make-page 1 0))

1302

1303

(defparameter *page-cache* nil)

1304

1305

(defun clear-page-cache ()

1306

(setq *page-cache*

1307

(map-into (make-array 16 :adjustable t)

1308

                   #'(lambda () (make-array 16 :adjustable nil :fill-pointer 0 :initial-element nil)))))

1309

(clear-page-cache)

1310

1311

(defparameter *page-cache-count-maximum* 16)

1312

(defparameter *page-cache-lock* (bt:make-lock "page cache"))

1313

1314

(defun get-page-cache (width)

1315

(when (< (length *page-cache*) width)

1316

(setq *page-cache* (adjust-array *page-cache* width))

1317

(map-into *page-cache*

1318

#'(lambda (v)

1319

(if (vectorp v)

1320

v

1321

(make-array 16 :adjustable nil :fill-pointer 0 :initial-element nil)))

1322

*page-cache*))

1323

(aref *page-cache* (1- width)))

1324

1325

1326

(defun make-page (length width)

1327

(cond ((and *page-cache* (= length *field-page-length*))

1328

(flet ((new-page ()

1329

(incf *page-count*)

1330

                   (make-array (list length width) :element-type 'fixnum :initial-element +NULL-TERM-ID+))

1331

#-sbcl

1332

(clear-page (page)

1333

(let ((length (* (array-dimension page 0) (array-dimension page 1))))

1334

(dotimes (i length)

1335

(setf (row-major-aref page i) +NULL-TERM-ID+)))

1336

page)

1337

#+sbcl

1338

(clear-page (page)

1339

(fill (sb-impl::%array-data-vector page) +NULL-TERM-ID+)

1340

page))

1341

(if (plusp width)

1342

(bt:with-lock-held (*page-cache-lock*)

1343

(let ((cache (get-page-cache width)))

1344

(if (plusp (fill-pointer cache))

1345

(clear-page (vector-pop cache))

1346

(new-page))))

1347

(new-page))))

1348

(t

1349

(incf *page-count*)

1350

(make-array (list length width) :element-type 'fixnum))))

1351

1352

(defun release-page (page)

1353

(assert-argument-types release-page (page array))

1354

(when (and *page-cache* (= (array-dimension page 0) *field-page-length*))

1355

(bt:with-lock-held (*page-cache-lock*)

1356

(let ((cache (get-page-cache (array-dimension page 1))))

1357

(assert-argument-types release-page (cache vector))

1358

(when (< (fill-pointer cache) (array-dimension cache 0))

1359

(vector-push page cache))))))

1360

1361

(defun adjust-page (page dimensions)

1362

(adjust-array page dimensions))

1363

1364

#-sbcl

1365

(defun copy-page (page &optional (new-page (apply #'make-page (array-dimensions page))))

1366

(let* ((dimensions (array-dimensions page))

1367

(size (apply #'* dimensions))

1368

(source (make-array size :displaced-to page :element-type 'fixnum))

1369

(destination (make-array size :displaced-to new-page :element-type 'fixnum)))

1370

(replace destination source)

1371

new-page))

1372

#+sbcl

1373

(defun copy-page (page &optional (new-page (apply #'make-page (array-dimensions page)) np-s))

1374

(when np-s (assert (equal (array-dimensions new-page) (array-dimensions page)) ()

1375

                      "page dimensions not identical: ~s != ~s." (array-dimensions new-page) (array-dimensions page)))

1376

(let* ((source (sb-impl::%array-data-vector page))

1377

(destination (sb-impl::%array-data-vector new-page)))

1378

(replace destination source)

1379

new-page))

1380

1381

#-sbcl

1382

(defun clear-page (page)

1383

(assert (arrayp page) () "clear-page: invalid page data: ~a" page)

1384

(let ((length (* (array-dimension page 0) (array-dimension page 1))))

1385

(dotimes (i length)

1386

(setf (row-major-aref page i) +NULL-TERM-ID+)))

1387

page)

1388

#+sbcl

1389

(defun clear-page (page)

1390

(assert (arrayp page) () "clear-page: invalid page data: ~a" page)

1391

(fill (sb-impl::%array-data-vector page) +NULL-TERM-ID+)

1392

page)

1393

1394

;; (defun make-pages (count) (dotimes (x count) (release-page (make-page *field-page-length* 4))))

1395

;; (defun make-arrays (count) (dotimes (x count) (make-array (list *field-page-length* 4))))

1396

1397

(defmacro do-pages ((page source) &rest body)

1398

(let ((op (gensym "do-pages")))

1399

`(flet ((,op (,page)

1400

(declare (ignorable ,page))

1401

(block nil ,@body)))

1402

(declare (dynamic-extent #',op))

1403

(map-pages #',op ,source))))

1404

1405

#+mcl

1406

(setf (ccl:assq 'do-pages ccl:*fred-special-indent-alist*) 1)

1407

1408

1409

(defgeneric map-pages (function source)

1410

(:documentation "Apply the given FUNCTION to each of the pages from the given SOURCE

1411

with appropriate steps to release once no linger in use.")

1412

(:method (op (source function))

1413

(loop for page = (funcall source)

1414

until (null page)

1415

do (funcall op page))))

1416

1417

1418

(declaim (ftype (function (fixnum fixnum) (simple-array fixnum (* *))) make-page))

1419

1420

1421

(defmacro do-solution-field (solution-variables solution-field &body body)

1422

"nb. the operator is used both for arbitrary solution fields and triple/quad

1423

fields. In the former case, there is no concern for order, but triples/quads

1424

should maintain sexp-statement order as there is no otehr indication."

1425

1426

(let ((step-op (gensym "do-solution-field-step"))

1427

(access-op (gensym "do-solution-field-reader")))

1428

`(flet ((,step-op ,solution-variables

1429

(declare (fixnum ,@solution-variables))

1430

,@body)

1431

(,access-op (step-op page solution-index)

1432

(declare (type (simple-array fixnum (* ,(length solution-variables))) page)

1433

(function step-op)

1434

(optimize (speed 3) (safety 0)))

1435

(funcall step-op ,@(loop for i from 0 below (length solution-variables)

1436

                                        collect `(aref page solution-index ,i)))))

1437

(declare (dynamic-extent #',step-op #',access-op))

1438

(map-solution-field #',step-op #',access-op ,solution-field))))

1439

#+digitool

1440

(setf (ccl:assq 'do-solution-field ccl:*fred-special-indent-alist*) 2)

1441

1442

1443

(defgeneric map-solution-field (step-function reader-function solution-field)

1444

(:method (step-function reader-function (solution-field vector))

1445

(loop for page across solution-field

1446

do (map-solution-field step-function reader-function page)))

1447

(:method ((step-function t) (access-function function) (solution-page array))

1448

(dotimes (solution-index (array-dimension solution-page 0))

1449

(funcall access-function step-function solution-page solution-index)))

1450

(:method (step-function access-function (field solution-field))

1451

(map-solution-field step-function access-function (solution-field-solutions field))))

1452

1453

#+(or)

1454

(defmacro do-solution-field-inline (solution-variables solution-field &body body &environment env)

1455

(let* ((field-var (if (eq solution-field (macroexpand-1 solution-field env))

1456

solution-field (gensym "field-")))

1457

(field-index (gensym))

1458

(body `(locally

1459

                   (declare (type (simple-array fixnum (* ,(length solution-variables))) ,field-var))

1460

(loop for ,field-index from 0 below (array-dimension ,field-var 0)

1461

do (progn ,@body)))))

1462

`(macrolet ,(loop for variable in solution-variables

1463

for variable-index from 0

1464

collect `(,variable (aref ,field-var ,field-index ,variable-index)))

1465

,(if (eq field-var solution-field)

1466

body

1467

`(let `((,field-var ,solution-field)) ,body)))))

1468

1469

1470

(defmacro do-solution-field-inline (solution-variables solution-field &body body)

1471

`(let ((.field. ,solution-field))

1472

(dotimes (i (length .field.))

1473

(let ((.page. (aref .field. i)))

1474

(declare (type (simple-array fixnum (* ,(length solution-variables))) .page.)

1475

(optimize (speed 3) (safety 0)))

1476

;; allow short pages

1477

(dotimes (.solution-index. (array-dimension .page. 0))

1478

(let ,(loop for i from 0 below (length solution-variables)

1479

for var in solution-variables

1480

collect `(,var (aref .page. .solution-index. ,i)))

1481

,@body))))))

1482

1483

1484

(defmacro field-object-aref (field i j &optional name)

1485

"Return a reference to a field array as a lisp object. The mapping delegates to rdfcache's

1486

construction/caching mechanism except in the case of a null term, which is recognized here mapped to

1487

an unbound variable instance. NB. the instance must be returned as that acts as a quasi-first-class

1488

value for sort predicates."

1489

1490

`((lambda (id)

1491

(if (= id +null-term-id+)

1492

,(spocq:make-unbound-variable name)

1493

(term-number-object id)))

1494

(aref ,field ,i ,j)))

1495

1496

(defmacro field-vector-object-aref (field-vector j &optional name)

1497

"Return a reference to a field array as a lisp object. The mapping delegates to rdfcache's

1498

construction/caching mechanism except in the case of a null term, which is recognized here mapped to

1499

an unbound variable instance. NB. the instance must be returned as that acts as a quasi-first-class

1500

value for sort predicates."

1501

1502

`((lambda (id)

1503

(if (= id +null-term-id+)

1504

,(spocq:make-unbound-variable name)

1505

(term-number-object id)))

1506

(aref ,field-vector ,j)))

1507

1508

1509

(define-setf-expander field-object-aref (field i j &optional name &environment env)

1510

(declare (ignore name))

1511

(multiple-value-bind (dummies vals newval setter getter)

1512

(get-setf-expansion field env)

1513

(declare (ignore newval setter))

1514

(let ((store (gensym)))

1515

(values dummies

1516

vals

1517

`(,store)

1518

`(setf (aref ,getter ,i ,j) (object-term-number ,store))

1519

`(aref ,getter ,i ,j)))))

1520

;;; (macroexpand-1 '(field-object-aref page index offset))

1521

;;; (macroexpand-1 '(field-object-aref page index offset var))

1522

;;; (macroexpand-1 '(setf (field-object-aref page index offset var) 2))

1523

1524

(defmacro field-object-or-unbound-aref (field i j &optional name)

1525

;; allow an unbound variable instance

1526

;; for sbcl works only read-only - otherwise it objects to possible of writing it back

1527

`(or (term-number-object (aref ,field ,i ,j))

1528

(load-time-value (spocq:make-unbound-variable ',name))))

1529

1530

(defmacro field-aref (field i j)

1531

"Provide a retargetable interface to matrix elements."

1532

`(aref ,field ,i ,j))

1533

1534

(defmacro field-vector-aref (field-vector j)

1535

"Provide a retargetable interface to vector elements."

1536

`(aref ,field-vector ,j))

1537

1538

(defsetf field-aref (field i j) (value)

1539

`(setf (aref ,field ,i ,j) ,value))

1540

1541

(defsetf field-vector-aref (field-vector j) (value)

1542

`(setf (aref ,field-vector ,j) ,value))

1543

1544

(defun field-object-aref-p (expression)

1545

(and (consp expression)

1546

(eq (first expression) 'field-object-aref)))

1547

1548

(defun field-vector-object-aref-p (expression)

1549

(and (consp expression)

1550

(eq (first expression) 'field-vector-object-aref)))

1551

1552

(defun field-object-aref-aref (expression)

1553

"Return just the aref proper from a field-object-aref expression"

1554

(subseq expression 1 4))

1555

1556

(defun field-vector-object-aref-aref (expression)

1557

"Return just the aref proper from a field-vector-object-aref expression"

1558

(subseq expression 1 3))

1559

1560

(defun default-context-p (term)

1561

(equal *default-context-identifier* term))

1562

(defun default-context-term-number-p (term-number)

1563

(or (eql term-number rdfcache:*default-context-number*)

1564

(eql term-number #xffffffff)))

1565

(declaim (inline default-context-term-number-p))

1566

1567

(defun abstract-graph-term-p (term)

1568

(case term

1569

((|urn:dydra|:|named| |urn:dydra|:|all| |urn:dydra|:|default|)

1570

t)

1571

(t

1572

nil)))

1573

1574

(defun wildcard-term-p (term)

1575

(equal *wildcard-identifier* term))

1576

1577

;;; note, the difference signatures require distint predicates

1578

(defun term-number-object-p (expression)

1579

(and (consp expression)

1580

(eq (first expression) 'term-number-object)))

1581

1582

(defun statement-properties (statement)

1583

(member-if #'keywordp statement))

1584

1585

(defun (setf statement-properties) (properties statement)

1586

(or (loop for rest on statement

1587

when (keywordp (first (rest rest)))

1588

do (progn (setf (rest rest) properties)

1589

(return properties)))

1590

(setf (rest (last statement)) properties)))

1591

1592

(defun statement-count (statement)

1593

(getf (statement-properties statement) :count))

1594

1595

(defun (setf statement-count) (count statement)

1596

(if count

1597

(setf (getf (statement-properties statement) :count) count)

1598

(remf (statement-properties statement) :count))

1599

count)

1600

1601

(defun statement-dimensions (statement)

1602

(or (getf (statement-properties statement) :dimensions)

1603

(setf (getf (statement-properties statement) :dimensions)

1604

(loop for term in (statement-terms statement)

1605

collect (if (variable-p term)

1606

term

1607

(gensym "constant"))))))

1608

1609

;;; no setter: it is generated on-demand

1610

;;;(defun (setf statement-dimensions) (dimensions statement)

1611

;;; (setf (getf (statement-properties statement) :dimensions) dimensions))

1612

1613

(defun statement-terms (statement)

1614

(labels ((butlast-keyword (list)

1615

(loop for element in list

1616

until (keywordp element)

1617

collect element)))

1618

(case (first statement)

1619

((spocq.a:|triple| :triple spocq.a:|quad| :quad)

1620

(butlast-keyword (rest statement)))

1621

(t (butlast-keyword statement)))))

1622

;;; (mapcar #'statement-terms '((:quad s p o) (:quad s p 3 :equivalents ((o 3)))))

1623

1624

(defun statement-variables (statement)

1625

(remove-if-not #'variable-p (statement-terms statement)))

1626

(defun statement-constants (statement)

1627

(remove-if-not #'spocq.e:constantp (statement-terms statement)))

1628

(defun statement-blank-nodes (statement)

1629

(remove-if-not #'spocq:blank-node-p (statement-terms statement)))

1630

1631

(defun statement-subject (statement)

1632

(case (first statement)

1633

((spocq.a:|triple| :triple spocq.a:|quad| :quad) (second statement))

1634

(t (case (length statement)

1635

;; 3 -> s.p.o, 4 -> c.s.p.o

1636

(3 (first statement))

1637

(4 (second statement))))))

1638

1639

(defun statement-predicate (statement)

1640

(case (first statement)

1641

((spocq.a:|triple| :triple spocq.a:|quad| :quad) (third statement))

1642

(t (case (length statement)

1643

;; 3 -> s.p.o, 4 -> c.s.p.o

1644

(3 (second statement))

1645

(4 (third statement))))))

1646

1647

(defun statement-object (statement)

1648

(case (first statement)

1649

((spocq.a:|triple| :triple spocq.a:|quad| :quad) (fourth statement))

1650

(t (case (length statement)

1651

;; 3 -> s.p.o, 4 -> c.s.p.o

1652

(3 (third statement))

1653

(4 (fourth statement))))))

1654

1655

(defun statement-context (statement)

1656

(case (first statement)

1657

((spocq.a:|triple| :triple) nil)

1658

((spocq.a:|quad| :quad) (fifth statement))

1659

(t (case (length statement)

1660

;; 3 -> s.p.o, 4 -> c.s.p.o

1661

(3 nil)

1662

(4 (first statement))))))

1663

1664

(defun triple-terms (statement)

1665

(labels ((butlast-keyword (list)

1666

(loop for element in list

1667

until (keywordp element)

1668

collect element)))

1669

(case (first statement)

1670

((spocq.a:|triple| :triple) (butlast-keyword (rest statement)))

1671

(t (butlast-keyword statement)))))

1672

1673

(defun quad-terms (statement)

1674

(statement-terms statement))

1675

1676

1677

(defun statement-options (statement)

1678

(member-if #'keywordp (rest statement)))

1679

1680

(defmacro solution-value (form)

1681

"Iff the form is an expression, wrap evaluation in a handler which suppresses errors

1682

and replaces them with an unbound variable. If the form is atomic, just evaluate it."

1683

1684

(if (consp form)

1685

`(handler-case ,form

1686

(condition (c)

1687

(declare (ignore c))

1688

(load-time-value (spocq:make-unbound-variable ',form)))

1689

(:no-error (value &rest values) (declare (ignore values))

1690

(case value

1691

((t) spocq.a:|true|)

1692

((nil) spocq.a:|false|)

1693

(t value))))

1694

form))

1695

1696

(defun find-statement (statements &key subject predicate object context)

1697

(loop for statement in statements

1698

when (and (or (null subject) (equal (statement-subject statement) subject))

1699

(or (null predicate) (equal (statement-predicate statement) predicate))

1700

(or (null object) (equal (statement-object statement) object))

1701

(or (null context) (equal (statement-context statement) context)))

1702

do (return statement)))

1703

1704

(defun statement-property-list (statements &key subject predicate object context)

1705

(loop for statement in statements

1706

when (and (or (null subject) (funcall subject (statement-subject statement)))

1707

(or (null predicate) (funcall predicate (statement-predicate statement)))

1708

(or (null object) (funcall object (statement-object statement)))

1709

(or (null context) (funcall context (statement-context statement))))

1710

collect (statement-predicate statement)

1711

collect (statement-object statement)))

1712

1713

#|

1714

;; (loop for i from 0 below 8 sum (* i *field-page-length* 4))

1715

1716

(defun test-field-array (&optional (count 100))

1717

(dotimes (pass count)

1718

(let ((field (make-array 8))

1719

(sum 0))

1720

(dotimes (i 8)

1721

         (setf (aref field i) (make-array (list *field-page-length* 4) :initial-element i :element-type 'fixnum)))

1722

(do-solution-field (a b c d) field

1723

(incf sum a)

1724

(incf sum b)

1725

(incf sum c)

1726

(incf sum d))

1727

sum)))

1728

;; (time (test-field-array)) : 0.141 seconds / 13,246,000 bytes consed

1729

1730

(defun test-field-array-inline (&optional (count 100))

1731

(dotimes (pass count)

1732

(let ((field (make-array 8))

1733

(sum 0))

1734

(dotimes (i 8)

1735

         (setf (aref field i) (make-array (list *field-page-length* 4) :initial-element i :element-type 'fixnum)))

1736

(do-solution-field-inline (a b c d) field

1737

(incf sum a)

1738

(incf sum b)

1739

(incf sum c)

1740

(incf sum d))

1741

sum)))

1742

;; (time (test-field-array-inline)) : 0.167 seconds of real time

1743

;; no real advantage over out-of-line

1744

1745

(defun test-field-list (&optional (count 100))

1746

(dotimes (pass count)

1747

(let ((field (loop for i from 0 below 8

1748

collect (loop for j from 0 below *field-page-length*

1749

collect (loop for var in '(a b c d)

1750

                                                    nconc `(,var ,i)))))

1751

(result 0))

1752

(flet ((op (&key ((a a) 0) ((b b) 0) ((c c) 0) ((d d) 0))

1753

(incf result a)

1754

(incf result b)

1755

(incf result c)

1756

(incf result d)))

1757

(declare (dynamic-extent #'op))

1758

(dolist (page field)

1759

(dolist (solution page)

1760

(apply #'op solution))))

1761

result)))

1762

;; (time (test-field-list)) : 0.487 seconds of real time / 65,573,504 bytes consed

1763

|#

1764

1765

1766

;;;

1767

;;; digests

1768

1769

(defun make-digest (string type)

1770

(let* ((length (length string))

1771

(buffer-length (* length 4))

1772

(buffer (make-array buffer-length :element-type '(unsigned-byte 8)))

1773

(count 0)

1774

(hex-characters "0123456789abcdef")

1775

(encoder (load-time-value (content-encoding-byte-encoder (content-encoding :utf-8)))))

1776

(flet ((buffer-insert-byte (buffer byte)

1777

(declare (type (array (unsigned-byte 8) (*)) buffer))

1778

(declare (type (unsigned-byte 8) byte))

1779

;; check bounds here as it's finally the encoded positioning

1780

(assert (< count buffer-length) () "redis key overrun.")

1781

(setf (aref buffer count) byte)

1782

(incf count)))

1783

(declare (dynamic-extent #'buffer-insert-byte)) ; just in case

1784

(dotimes (i length)

1785

(funcall encoder (char string i) #'buffer-insert-byte buffer))

1786

(let* ((digest (ironclad:digest-sequence type buffer :end count))

1787

(hex-digest (make-array (* (length digest) 2) :element-type 'character)))

1788

(loop for digest-byte across digest

1789

for hex-index from 0 below (length hex-digest) by 2

1790

do (setf (char hex-digest hex-index) (aref hex-characters (ash digest-byte -4))

1791

                        (char hex-digest (1+ hex-index)) (aref hex-characters (logand digest-byte #x0f))))

1792

(values hex-digest digest)))))

1793

1794

(defun make-md5-digest (string) (make-digest string 'ironclad:md5))

1795

(defun make-sha1-digest (string) (make-digest string 'ironclad:sha1))

1796

(defun make-sha224-digest (string) (make-digest string 'ironclad:sha224))

1797

(defgeneric make-sha256-digest (object)

1798

(:documentation "return a base-16 hex string encoding of the sha256 hash value of the

1799

given object. given a pathname, compute the hash from the respective file.

1800

    when used to construct a urn, this encoding differs from https://tools.ietf.org/html/draft-thiemann-hash-urn-01.")

1801

(:method ((string string)) (make-digest string 'ironclad:sha256))

1802

(:method ((pathname pathname))

1803

(let ((process (run-program *executable-pathname.shasum*

1804

`("-a" "256" ,(namestring (truename pathname)))

1805

:environment ()

1806

:output :stream

1807

))) ;; isolate rapper from dydra libraries

1808

(unless (and process (zerop (run-program-exit-code process)))

1809

(error "make-sha256-digest failed: ~s" (run-program-exit-code process)))

1810

(unwind-protect (let* ((hash (read-line (run-program-output process)))

1811

(end (position-if-not #'alphanumericp hash)))

1812

(subseq hash 0 end))

1813

(run-program-close process)))))

1814

(defun make-sha384-digest (string) (make-digest string 'ironclad:sha384))

1815

(defun make-sha512-digest (string) (make-digest string 'ironclad:sha512))

1816

;;; (mapcar #'(lambda (f) (funcall f "")) '(make-md5-digest make-sha1-digest make-sha224-digest))

1817

;;; (mapcar #'(lambda (f) (funcall f "")) '(make-sha256-digest make-sha384-digest make-sha512-digest))

1818

1819

(defgeneric iri-sha1 (iri)

1820

(:documentation "Given an iri string or object, compute the sha1 for its

1821

ntriples encoding.")

1822

(:method ((iri string))

1823

(make-sha1-digest (concatenate 'string "<" iri ">")))

1824

(:method ((iri spocq:iri))

1825

(iri-sha1 (spocq:iri-lexical-form iri)))

1826

(:method ((iri symbol))

1827

(iri-sha1 (iri-lexical-form iri)))

1828

(:method ((uri puri:uri))

1829

(iri-sha1 (with-output-to-string (stream) (puri:render-uri uri stream)))))

1830

1831

;;;

1832

;;; os interface operators

1833

;;;

1834

1835

;;; logging

1836

1837

(defun log-level-qualifies? (level)

1838

(find level (member *log-level* *log-levels*)))

1839

1840

#+sbcl

1841

(progn

1842

(defun posix-log-level (level)

1843

(or (rest (assoc level (load-time-value `((:trace . ,sb-posix:log-debug)

1844

                                               (:debug . ,sb-posix:log-debug)

1845

                                               (:info . ,sb-posix:log-info)

1846

                                               (:notice . ,sb-posix:log-notice)

1847

                                               (:warn . ,sb-posix:log-warning)

1848

                                               (:error . ,sb-posix:log-err)

1849

                                               (:critical . ,sb-posix:log-crit)

1850

                                               (:fatal . ,sb-posix:log-emerg)))))

1851

sb-posix:log-err))

1852

(defun posix-option-flag (key)

1853

(or (rest (assoc key (load-time-value `((:cons . ,sb-posix:log-cons)

1854

                                             (:ndelay . ,sb-posix:log-ndelay)

1855

                                             (:nowait . ,sb-posix:log-nowait)

1856

                                             (:odelay . ,sb-posix:log-odelay)

1857

                                             (:perror . ,sb-posix:log-perror)

1858

                                             (:pid . ,sb-posix:log-pid)))))

1859

0))

1860

(defun posix-log-facility (facility)

1861

(or (rest (assoc facility (load-time-value `((:authpriv . ,sb-posix:log-authpriv)

1862

(:cron . ,sb-posix:log-cron)

1863

                                             (:daemon . ,sb-posix:log-daemon)

1864

(:ftp . ,sb-posix:log-ftp)

1865

(:lpr . ,sb-posix:log-lpr)

1866

(:mail . ,sb-posix:log-mail)

1867

(:news . ,sb-posix:log-news)

1868

                                             (:syslog . ,sb-posix:log-syslog)

1869

(:user . ,sb-posix:log-user)

1870

                                             (:uucp . ,sb-posix:log-uucp)))))

1871

0)))

1872

1873

#+lispworks

1874

(progn

1875

(defun posix-log-level (level)

1876

(or (rest (assoc level (load-time-value `((:trace . 7)

1877

(:debug . 7)

1878

(:info . 6)

1879

(:notice . 5)

1880

(:warn . 4)

1881

(:error . 3)

1882

(:critical . 2)

1883

(:fatal . 1)))))

1884

3))

1885

(defun posix-option-flag (key)

1886

(or (rest (assoc key (load-time-value `((:cons . 2)

1887

(:ndelay . 8)

1888

(:nowait . 16)

1889

(:odelay . 4)

1890

(:perror . 32)

1891

(:pid . 1)))))

1892

0))

1893

(defun posix-log-facility (facility)

1894

(or (rest (assoc facility (load-time-value `((:authpriv . 10)

1895

(:chron . 9)

1896

(:daemon . 3)

1897

(:ftp . 11)

1898

(:lpr . 6)

1899

(:mail . 2)

1900

(:news . 7)

1901

(:syslog . 5)

1902

(:user . 1)

1903

(:uucp . 8)))))

1904

0)))

1905

#+mcl

1906

(progn

1907

(defun posix-log-level (level)

1908

(or (rest (assoc level (load-time-value `((:trace . ,bsd::log-debug)

1909

                                               (:debug . ,bsd::log-debug)

1910

(:info . ,bsd::log-info)

1911

                                               (:notice . ,bsd::log-notice)

1912

                                               (:warn . ,bsd::log-warning)

1913

(:error . ,bsd::log-err)

1914

                                               (:critical . ,bsd::log-crit)

1915

                                               (:fatal . ,bsd::log-emerg)))))

1916

bsd::log-err))

1917

(defun posix-option-flag (key)

1918

(or (rest (assoc key (load-time-value `((:cons . ,bsd::log-cons)

1919

(:ndelay . ,bsd::log-ndelay)

1920

(:nowait . ,bsd::log-nowait)

1921

(:odelay . ,bsd::log-odelay)

1922

(:perror . ,bsd::log-perror)

1923

(:pid . ,bsd::log-pid)))))

1924

0))

1925

(defun posix-log-facility (facility)

1926

(or (rest (assoc facility (load-time-value `((:authpriv . ,bsd::log-authpriv)

1927

(:chron . ,bsd::log-chron)

1928

(:daemon . ,bsd::log-daemon)

1929

(:ftp . ,bsd::log-ftp)

1930

(:lpr . ,bsd::log-lpr)

1931

(:mail . ,bsd::log-mail)

1932

(:news . ,bsd::log-news)

1933

(:syslog . ,bsd::log-syslog)

1934

(:user . ,bsd::log-user)

1935

(:uucp . ,bsd::log-uucp)))))

1936

0)))

1937

1938

#+sbcl

1939

(defmacro without-interrupts (&body body)

1940

`(sb-sys:without-interrupts ,@body))

1941

1942

#-sbcl

1943

(defmacro without-interrupts (&body)

1944

(cerror "continue to compile" "no definition present for without-interrupts")

1945

`(progn ,@body))

1946

1947

1948

1949

;;; define an open-log version which ensure that the

1950

;;; identity string is projected into the c heap.

1951

1952

(cffi:defcfun ("openlog" %openlog) :void (id :string) (options :int) (facility :int))

1953

1954

(defun open-log (&key (identity *service-name*) (options nil) (facility :log-daemon) (title nil))

1955

(when (stringp identity)

1956

(setf identity (cffi:foreign-string-alloc identity)))

1957

(when (listp options)

1958

(setf options (reduce #'+ options :key #'posix-option-flag :initial-value 0)))

1959

(when (symbolp facility)

1960

(setf facility (posix-log-facility facility)))

1961

(when title

1962

#+sbcl

1963

(let* ((title-pointer (sb-alien:deref sb-sys::*native-posix-argv* 0))

1964

(old-title (sb-alien:cast title-pointer sb-alien:c-string))

1965

(title-length (length old-title)))

1966

(dotimes (i (min title-length (length title)))

1967

(setf (sb-alien:deref title-pointer i) (char-code (char title i))))))

1968

(%openlog identity options facility))

1969

1970

(cffi:defcfun ("syslog" %syslog) :void (priority :int) (c-format :string) (c-message :string))

1971

1972

(defun write-log (level format-control &rest args)

1973

(handler-case (let* ((*print-pretty* nil)

1974

(*print-length* 10)

1975

                        (message (format nil "[~a] ~?" *thread-name* format-control args)))

1976

(without-interrupts

1977

(cffi:with-foreign-strings ((%cformat "%s")

1978

(%message message))

1979

(%syslog (posix-log-level level) %cformat %message)))

1980

;; write anything above :notice to the terminal, if present

1981

(when (and (not (find :notice (member level *log-levels*)))

1982

*trace-output*

1983

(interactive-stream-p *trace-output*))

1984

(format *trace-output* "~&;;;~a~%" message)))

1985

(error (error)

1986

(setq *log-condition* error)

1987

nil)))

1988

1989

1990

(defun call-if-log-level-p (level operator)

1991

"Given a log LEVEL and an OPERATOR, call the operator iff the log level is satisfied."

1992

(declare (dynamic-extent operator))

1993

(when (log-level-qualifies? level)

1994

(funcall operator)))

1995

1996

1997

(macrolet ((def-log-op (level)

1998

`(progn

1999

(defun ,(cons-symbol :spocq.i :write-log- level) (format-control &rest args)

2000

(when (log-level-qualifies? ,level)

2001

(apply #'write-log ,level format-control args)))

2002

(defmacro ,(cons-symbol :spocq.i :log- level) (format-control &rest args)

2003

`(flet ((call-write-log ()

2004

(write-log ,,level ,format-control ,@args)

2005

t))

2006

(declare (dynamic-extent (function call-write-log)))

2007

(call-if-log-level-p ,,level (function call-write-log))))

2008

(defun ,(cons-symbol :spocq.i :log- level "!") (format-control &rest args)

2009

(apply #'write-log ,level format-control args)))))

2010

(def-log-op :fatal)

2011

(def-log-op :critical)

2012

(def-log-op :error)

2013

(def-log-op :warn)

2014

(def-log-op :notice)

2015

(def-log-op :info)

2016

(def-log-op :debug))

2017

2018

(defmacro log-trace (format-control &rest args)

2019

`(flet ((call-write-log ()

2020

(write-log :trace ,format-control ,@args)

2021

(terpri *trace-output*)

2022

(format *trace-output* ,format-control ,@args)

2023

t))

2024

(declare (dynamic-extent #'call-write-log))

2025

(call-if-log-level-p :trace #'call-write-log)))

2026

(defun log-trace! (format-control &rest args)

2027

(apply #'write-log :trace format-control args))

2028

2029

2030

(defun log-stacktrace (format-control &rest args)

2031

(flet ((call-write-log ()

2032

(apply #'write-log :error format-control args)

2033

(handler-case

2034

(bt:with-recursive-lock-held (*trace-lock*)

2035

                (with-open-file (stream *log-pathname* :direction :output :if-exists :append :if-does-not-exist :create

2036

                                        #+(or sbcl lispworks) :external-format #+sbcl :utf8  #+lispworks :utf-8)

2037

(format stream "~&~%[~/date:format-iso-time/ ~s]~% ~?"

2038

(get-universal-time) (getpid) format-control args)

2039

(print-stacktrace stream)))

2040

(error (error)

2041

(log-error "failed to write tracelog entry: ~a" error)

2042

(setq *log-condition* error)

2043

nil))))

2044

(call-write-log)))

2045

2046

(defun write-tracelog (format-control &rest args)

2047

(handler-case

2048

     (with-open-file (stream *log-pathname* :direction :output :if-exists :append :if-does-not-exist :create

2049

                             #+(or sbcl lispworks) :external-format #+sbcl :utf8  #+lispworks :utf-8)

2050

(format stream "~&~%[~/date:format-iso-time/ ~s]~% ~?"

2051

(get-universal-time) (getpid) format-control args))

2052

(error (error)

2053

(log-error "failed to write tracelog entry: ~a" error)

2054

(setq *log-condition* error)

2055

nil)))

2056

2057

(defgeneric log-metadata (message object)

2058

(:method (message (object t))

2059

(log-debug "~a ~a" message object)))

2060

2061

#+clozure

2062

(defun print-stacktrace (stream &key (start 0) (count) (verbosity 1))

2063

nil)

2064

2065

2066

#+lispworks

2067

(defun print-stacktrace (stream &key (start 0) (count) (verbosity 1))

2068

(let ((*standard-output* stream))

2069

(mp:print-process-stack-frames mp:*current-process*)))

2070

2071

2072

#+mcl

2073

(defun print-stacktrace (stream &key (start 0) (count) (verbosity 1))

2074

(declare (ignore count))

2075

(let ((*debug-io* stream))

2076

     (ccl::print-call-history :stack-group ccl::*current-stack-group* :start-frame start :detailed-p (plusp verbosity))))

2077

2078

#+sbcl

2079

(defun print-stacktrace (stream &key (start 0) (count most-positive-fixnum) (verbosity 1)

2080

((:print-array *print-array*) nil)

2081

((:print-pretty *print-pretty*) nil))

2082

(declare (ignore verbosity))

2083

(fresh-line stream)

2084

(sb-debug::map-backtrace (lambda (frame)

2085

                              (sb-debug::print-frame-call frame stream ;:verbosity verbosity

2086

                                                          :number t))

2087

:start start

2088

:count count)

2089

(fresh-line stream))

2090

2091

 ;;; (sb-thread:interrupt-thread (first (sb-thread:list-all-threads)) #'(lambda () (print-stacktrace *trace-output*)))

2092

;;;

2093

2094

2095

#+sbcl

2096

(defmacro barrier ((kind) &body body)

2097

`(sb-thread:barrier (,kind) ,@body))

2098

2099

#-sbcl

2100

(defmacro barrier ((kind) &body body)

2101

(declare (ignore kind))

2102

`(progn ,@body))

2103

2104

;;; memory monitoring

2105

#+ccl

2106

(defun log-memory-usage ()

2107

;; always log it and leave to syslog to filter

2108

;; from room

2109

(multiple-value-bind (usedbytes static-used staticlib-used) (ccl::%usedbytes)

2110

(write-log :notice "MEMORY: dynamic ~d, static ~d, lib ~d; QUERIES: ~d"

2111

usedbytes

2112

static-used

2113

staticlib-used

2114

(query-count))))

2115

2116

#+lispworks

2117

(defun log-memory-usage (gen)

2118

;; always log it and leave to syslog to filter

2119

(write-log :notice "MEMORY: ~d/~a; QUERIES: ~d"

2120

gen (system:room-values) (query-count)))

2121

2122

#+sbcl

2123

(defun log-memory-usage ()

2124

(let* ((dynamic (sb-kernel::dynamic-usage))

2125

(level (cond ((<= dynamic 2000000000) :info)

2126

((<= dynamic 4000000000) :notice)

2127

(t :warn)))

2128

;; 7/8 or 1/2 the full heap size

2129

(limit (floor (* 7 (/ (/ (SB-EXT:DYNAMIC-SPACE-SIZE) 2) 8)))))

2130

(when (log-level-qualifies? level)

2131

(write-log level "MEMORY: dynamic ~d, static ~d, stack ~d; QUERIES: ~d"

2132

dynamic

2133

(sb-kernel::static-space-usage)

2134

(sb-kernel::control-stack-usage)

2135

(query-count)))

2136

(when (> dynamic limit)

2137

(bt:make-thread #'(lambda ()

2138

(write-log :warn "initiate full GC @~d" limit)

2139

(sb-ext:gc :full t))))))

2140

2141

(defun trace-when (stream format &rest args)

2142

(flet ((do-format ()

2143

(let ((*print-pretty* nil))

2144

(prog1 (etypecase format

2145

((or function symbol) (funcall format stream))

2146

(string (apply #'format stream format args)))

2147

(finish-output stream)))))

2148

(when stream

2149

(if (eq (sb-thread:mutex-owner *trace-lock*) (bt:current-thread))

2150

(do-format)

2151

(bt:with-recursive-lock-held (*trace-lock*) (do-format))))))

2152

2153

(defmacro trace-always (operator &rest values)

2154

(let ((op (gensym "trace-")))

2155

`(flet ((,op (,op)

2156

(format ,op "~&~a[~a] : ~@{~a~^ ~}~%"

2157

',operator (bt:thread-name (bt:current-thread)) ,@values)))

2158

(declare (dynamic-extent #',op))

2159

(trace-when *trace-output* #',op))))

2160

2161

(defvar *algebra-trace-output* nil)

2162

(defmacro trace-algebra (operator &rest values)

2163

(let ((op (gensym "trace-")))

2164

`(flet ((,op (,op)

2165

(format ,op "~&~a[~a] : "',operator (bt:thread-name (bt:current-thread)))

2166

               (format ,op ,(if (and (stringp (first values)) (find #\~ (first values))) (pop values) "~@{~a~^ ~}~%")

2167

,@values)

2168

(fresh-line ,op)))

2169

(declare (dynamic-extent #',op))

2170

(trace-when *algebra-trace-output* #',op))))

2171

2172

(defvar *bgp-trace-output* nil)

2173

(defmacro trace-bgp (operator &rest values)

2174

(let ((op (gensym "trace-")))

2175

`(flet ((,op (,op)

2176

(format ,op "~&bgp: ~a[~a] : ~@{~a~^ ~}~%"

2177

',operator (bt:thread-name (bt:current-thread)) ,@values)))

2178

(declare (dynamic-extent #',op))

2179

(trace-when *bgp-trace-output* #',op))))

2180

(defmacro trace-bgp-operator (operator &rest values)

2181

(let ((op (gensym "trace-")))

2182

`(flet ((,op (,op)

2183

(format ,op "~&bgp: ~a[~a] : ~@{~a~^ ~}~%"

2184

',operator (bt:thread-name (bt:current-thread)) ,@values)))

2185

(declare (dynamic-extent #',op))

2186

(trace-when *bgp-trace-output* #',op))))

2187

2188

2189

(defvar *data-trace-output* nil)

2190

(defmacro trace-data (operator &rest values)

2191

(let ((op (gensym "trace-")))

2192

`(flet ((,op (,op)

2193

(format ,op "~&~a[~a] : ~@{~a~^ ~}~%"

2194

',operator (bt:thread-name (bt:current-thread)) ,@values)))

2195

(declare (dynamic-extent #',op))

2196

(trace-when *data-trace-output* #',op))))

2197

2198

(defvar *thread-trace-output* nil)

2199

(defmacro trace-threads (operator &rest values)

2200

(etypecase operator

2201

((cons (eql function))

2202

`(trace-when *thread-trace-output* ,operator))

2203

((cons (eql lambda))

2204

`(trace-when *thread-trace-output* (function ,operator)))

2205

(symbol

2206

(let ((op (gensym "trace-")))

2207

`(flet ((,op (,op)

2208

(format ,op "~&~a[~a] : ~@{~a~^ ~}~%"

2209

',operator (bt:thread-name (bt:current-thread)) ,@values)))

2210

(declare (dynamic-extent #',op))

2211

(trace-when *thread-trace-output* #',op))))))

2212

2213

(defun trace-transaction (context %record &optional (read-only-p nil))

2214

(when *transaction-trace-output*

2215

(trace-when *transaction-trace-output*

2216

"~&~s~@[ ( ~s )~]" context read-only-p)

2217

(rdfcache:print-transaction %record *transaction-trace-output*)

2218

(terpri *transaction-trace-output*)))

2219

2220

(defvar *encoding-trace-output* nil)

2221

2222

;;;

2223

;;; external programs

2224

2225

(:documentation "external programs"

2226

"execute external processes given the full program pathname and the arguments.

2227

permit to supply an input stream and/or capture the output stream.")

2228

2229

(defparameter *run-program-verbose* t)

2230

2231

(defun run-program (executable command-arguments &rest process-arguments

2232

&key wait (environment nil e-p)

2233

&allow-other-keys)

2234

(setf executable (namestring executable))

2235

(log-notice "run-program: ~s . ~s~@[ . ~s~]"

2236

executable command-arguments process-arguments)

2237

#+sbcl

2238

(let ((process (apply #'sb-ext:run-program executable command-arguments

2239

(append (when e-p `(:environment ,environment))

2240

process-arguments))))

2241

(if wait

2242

(cond ((zerop (sb-ext:process-exit-code process))

2243

process)

2244

(t

2245

(when *run-program-verbose*

2246

(log-warn "run-program: abnormal exit: ~s: ~s . ~s"

2247

(sb-ext:process-exit-code process)

2248

executable command-arguments))

2249

(sb-ext:process-close process)

2250

;; return process in any case to afford access to the code

2251

process))

2252

process)))

2253

2254

#+sbcl

2255

(defun run-program-close (process)

2256

(sb-ext:process-wait process)

2257

(sb-ext:process-close process)

2258

;; read that to release the zombie

2259

(sb-ext:process-exit-code process))

2260

2261

(defun run-program-error (process)

2262

#+sbcl

2263

(sb-ext:process-error process))

2264

2265

(defun run-program-exit-code (process)

2266

#+sbcl

2267

(sb-ext:process-exit-code process))

2268

2269

(defun run-program-input (process)

2270

#+sbcl

2271

(sb-ext:process-input process))

2272

2273

(defun run-program-output (process)

2274

#+sbcl

2275

(sb-ext:process-output process))

2276

2277

(defun run-program-wait (process)

2278

#+sbcl

2279

(sb-ext:process-wait process))

2280

2281

(defmacro with-open-program ((stream executable command-arguments &rest process-arguments) &body body)

2282

`(call-with-open-program #'(lambda (,stream) ,@body)

2283

,executable ,command-arguments

2284

,@process-arguments))

2285

2286

(defun call-with-open-program (function executable command-arguments &rest process-arguments)

2287

(let ((process (apply #'run-program executable command-arguments

2288

:output :stream

2289

:wait nil

2290

process-arguments)))

2291

(cond (process

2292

(unwind-protect

2293

(case (run-program-exit-code process)

2294

((0 nil)

2295

(funcall function (run-program-output process)))

2296

(t (error "run-program failed: ~s: ~s"

2297

(run-program-exit-code process)

2298

(cons executable command-arguments))))

2299

(close (run-program-output process))

2300

(run-program-close process)))

2301

(t

2302

(error "run-program failed: ~s: ~s"

2303

(run-program-exit-code process)

2304

(cons executable command-arguments))))))

2305

2306

2307

(defun read-http-headers (stream &rest headers)

2308

"read the given stream, to extract the given headers up to the

2309

point of a zero-length line."

2310

(declare (dynamic-extent headers))

2311

(let ((whitespace #(#\space #\tab #\return #\linefeed)))

2312

(labels ((collector (collection)

2313

(let ((line (read-line stream nil nil)))

2314

(if (and (plusp (length line))

2315

(not (find (char line 0) whitespace)))

2316

(let* ((colon (position #\: line)))

2317

                        (if (and colon (= colon 3) (string-equal "via" line :end2 colon))

2318

;; pass over proxy headers

2319

                            (collector (append collection (apply #'read-http-headers stream headers)))

2320

(loop for header in headers

2321

when (and colon

2322

(= (length (string header)) colon)

2323

                                        (string-equal header line :end2 colon))

2324

                              return (collector (acons header (string-trim whitespace (subseq line (1+ colon)))

2325

                                                       collection))

2326

finally (return (collector collection)))))

2327

(reverse collection)))))

2328

(collector nil))))

2329

2330

;;; these are used in the encoding operators to compare with external the term datatype string

2331

;;; to judge that the term is a string with and explicit type

2332

(defparameter |%http://www.w3.org/2001/XMLSchema#string| nil)

2333

(defun |%http://www.w3.org/2001/XMLSchema#string| ()

2334

(or |%http://www.w3.org/2001/XMLSchema#string|

2335

(setf |%http://www.w3.org/2001/XMLSchema#string| (datatype-foreign-string '|xsd|:|string|))))

2336

2337

(defparameter |%http://www.w3.org/1999/02/22-rdf-syntax-ns#langString| nil)

2338

(defun |%http://www.w3.org/1999/02/22-rdf-syntax-ns#langString| ()

2339

(or |%http://www.w3.org/1999/02/22-rdf-syntax-ns#langString|

2340

       (setf |%http://www.w3.org/1999/02/22-rdf-syntax-ns#langString| (datatype-foreign-string '|rdf|:|langString|))))

2341

2342

(defun %string-equal (%s1 %s2)

2343

(and (not (cffi:null-pointer-p %s1))

2344

(not (cffi:null-pointer-p %s2))

2345

(loop for i from 0

2346

for c1 = (cffi:mem-ref %s1 :char i)

2347

for c2 = (cffi:mem-ref %s2 :char i)

2348

do (cond ((zerop c1)

2349

(return (zerop c2)))

2350

((zerop c2)

2351

(return nil))

2352

((= c1 c2))

2353

(t

2354

(return nil))))))

2355

2356

(defun string-begins-equal (string initial-string)

2357

(when (and string initial-string

2358

(>= (length string) (length initial-string)))

2359

(string-equal string initial-string :end1 (length initial-string))))

2360

2361

;;;

2362

;;; process information

2363

2364

#+clozure

2365

(defun getpid ()

2366

(ccl::getpid))

2367

2368

#+mcl

2369

(defun getpid ()

2370

(bsd:getpid))

2371

2372

#+lispworks

2373

(defun getpid ()

2374

(system::getpid))

2375

2376

#+sbcl

2377

(defun getpid ()

2378

(sb-posix:getpid))

2379

2380

(defun host-name ()

2381

(or *host-name*

2382

(setq *host-name*

2383

#+(or clozure mcl) (short-site-name)

2384

#+sbcl (sb-unix:unix-gethostname))))

2385

2386

(defun server-host-name ()

2387

(or *server-host-name*

2388

(setq *server-host-name* (host-name))))

2389

2390

(defun server-uri ()

2391

(or *server-uri*

2392

(setq *server-uri* (intern-iri (concatenate 'string *server-protocol* "://" (server-host-name))))))

2393

2394

(defun site-name ()

2395

(or *site-name*

2396

(setq *site-name* (host-name))))

2397

2398

(defun site-namespace ()

2399

"construct the site namespace uri on demand.

2400

this combines the site name always with the http protocol"

2401

(or *site-namespace*

2402

(setq *site-namespace* (intern-iri (concatenate 'string "http" "://" (site-name))))))

2403

2404

(defun site-uri ()

2405

"construct the site location uri on demand.

2406

this combines the site name with the active protocol - http or https as configured."

2407

(or *site-uri*

2408

(setq *site-uri* (intern-iri (concatenate 'string *site-protocol* "://" (site-name))))))

2409

2410

(defun query-exchange ()

2411

(or *query-exchange*

2412

(setq *query-exchange* (format nil "~a.query" *service-name*))))

2413

2414

(defun engine-query-queue-name ()

2415

(or *engine-query-queue*

2416

(setq *query-queue* (format nil "~a.query" *service-name*))))

2417

2418

(defun engine-store-queue-name ()

2419

(or *engine-store-queue*

2420

(setq *engine-store-queue* (format nil "~a.store.~a.~a" *service-name* (host-name) (getpid)))))

2421

2422

(defun engine-store-routing-key ()

2423

(or *engine-store-routing-key*

2424

(setq *engine-store-routing-key*

2425

(format nil "~a.spocq.~a" (host-name) (getpid)))))

2426

2427

(defun store-exchange ()

2428

(or *store-exchange*

2429

(setq *store-exchange* (format nil "~a.store" *service-name*))))

2430

2431

(defun store-store-queue-name ()

2432

(or *store-store-queue*

2433

(setq *store-store-queue* (format nil "~a.store" *service-name*))))

2434

2435

2436

2437

(defun getarg (arg)

2438

(etypecase arg

2439

(integer (nth arg (command-line-argument-list)))

2440

((or string keyword)

2441

(let ((arg-entry (member arg (command-line-argument-list) :test #'string-equal)))

2442

(if (and arg-entry (>= (length arg) 2) (char= #\- (char arg 1)))

2443

(let ((value (second arg-entry)))

2444

(if (and value (not (string-equal "--" value :end2 (min 2 (length value)))))

2445

value

2446

t))

2447

(not (null arg-entry)))))))

2448

(eval-when (:compile-toplevel :load-toplevel :execute)

2449

(defvar *getarg-options* ()))

2450

(define-compiler-macro getarg (&whole form arg)

2451

(when (stringp arg)

2452

(pushnew arg *getarg-options* :test #'string-equal))

2453

form)

2454

2455

(defun getargs (name)

2456

(loop with args = (command-line-argument-list)

2457

for arg = (pop args)

2458

until (null arg)

2459

when (equal arg name)

2460

collect (pop args)))

2461

2462

#+clozure

2463

(defun command-line-argument-list ()

2464

ccl:*command-line-argument-list*)

2465

2466

#+mcl

2467

(defun command-line-argument-list ()

2468

'("spocq"))

2469

2470

#+lispworks

2471

(defun command-line-argument-list ()

2472

system:*command-line-arguments-list*)

2473

2474

#+sbcl

2475

(defun command-line-argument-list ()

2476

sb-ext:*posix-argv*)

2477

2478

2479

#+ccl

2480

(defun get-space-time-usage ()

2481

;;(values (get-internal-run-time) (get-internal-real-time) (ccl::total-bytes-allocated)))

2482

(values (rdfcache:time-in-thread) (get-internal-real-time) (ccl::total-bytes-allocated)))

2483

2484

#+lispworks ; nb. 'utime' => microseconds

2485

(defun get-space-time-usage ()

2486

;;(values (get-internal-run-time) (get-internal-real-time) 0))

2487

(values (rdfcache:time-in-thread) (get-internal-real-time) 0))

2488

2489

#+sbcl ; nb. 'utime' => microseconds

2490

(defun get-space-time-usage ()

2491

;;(values (get-internal-run-time) (get-internal-real-time) (sb-impl::get-bytes-consed)))

2492

(values (rdfcache:time-in-thread) (get-internal-real-time) (sb-impl::get-bytes-consed)))

2493

2494

(defparameter *in.call-with-accounting* nil)

2495

2496

(defun accounting-properties ()

2497

"Return the accounting properties as accumulated since the start of a call-with-accounting

2498

and reset the values. The properties are in the form of a p-list with keys intended for an

2499

accounting note. allocation and time properties are then reset to their current values and the

2500

others are reset to zero."

2501

2502

(multiple-value-bind (run-time real-time bytes-allocated)

2503

(get-space-time-usage)

2504

(let ((delta-bytes (if (< bytes-allocated *bytes-allocated*)

2505

                            (+ bytes-allocated (- most-positive-fixnum *bytes-allocated*))

2506

(- bytes-allocated *bytes-allocated*))))

2507

(prog1 `(:|algebra_operations| ,*algebra-operations*

2508

:|bytes_allocated| ,delta-bytes

2509

:|bytes_read| ,*bytes-read*

2510

:|bytes_written| ,*bytes-written*

2511

:|match_requests| ,*match-requests*

2512

:|match_responses| ,*match-responses*

2513

:|run_time| ,(- run-time *run-time*)

2514

:|real_time| ,(- real-time *real-time*)

2515

:|solutions_constructed| ,*solutions-constructed*

2516

:|solutions_processed| ,*solutions-processed*

2517

:|solutions_returned| ,*statements-returned*)

2518

(unless *in.call-with-accounting*

2519

(warn "accounting-properties not in call-with-accounting"))

2520

(setq *bytes-allocated* bytes-allocated

2521

*bytes-read* 0

2522

*bytes-written* 0

2523

*match-requests* 0

2524

*match-responses* 0

2525

*algebra-operations* 0

2526

*run-time* run-time

2527

*real-time* real-time

2528

*solutions-constructed* 0

2529

*solutions-processed* 0

2530

*statements-returned* 0)))))

2531

2532

(defmacro with-accounting (&rest body)

2533

(let ((op (gensym "ACCOUNTING-CONTEXT-")))

2534

`(flet ((,op () ,@body))

2535

(declare (dynamic-extent #',op))

2536

(call-with-accounting #',op))))

2537

2538

(defun call-with-accounting (function)

2539

(declare (dynamic-extent function))

2540

(let ((*algebra-operations* 0)

2541

(*bytes-read* 0)

2542

(*bytes-written* 0)

2543

(*match-requests* 0)

2544

(*match-responses* 0)

2545

(*solutions-constructed* 0)

2546

(*solutions-processed* 0)

2547

(*statements-returned* 0)

2548

(*in.call-with-accounting* t))

2549

(multiple-value-bind (*run-time* *real-time* *bytes-allocated*)

2550

(get-space-time-usage)

2551

(funcall function))))

2552

2553

;;; an indirection for debugging

2554

(defgeneric put-accounting-note (task note)

2555

(:method ((task t) (note t))

2556

(log-stacktrace "invalid task accounting note: ~s . ~s" task note)

2557

note))

2558

2559

(defun generate-accounting-note (state &key (task *query*))

2560

;; a non-generic function to avoid dynamic compilation of an effective method

2561

;; which, in spcl can lead to the error "The value NIL is not of type SB-C::VOP"

2562

"Send a note to an accounting channel which combines the give query with an indicator for

2563

the processing state/phase and a snapshot of the accounting properties since the previous note."

2564

2565

(typecase state

2566

(null ; ignore it

2567

)

2568

(symbol

2569

(cond ((typep task 'task)

2570

(update-task-state task state)

2571

(put-accounting-note task

2572

(list* :|task_id| (task-id task)

2573

:|state| state

2574

(accounting-properties))))

2575

(t

2576

(log-stacktrace "invalid task for accounting note: ~s." task))))

2577

(t

2578

(log-stacktrace "invalid state for accounting note: ~s , ~s" state task))))

2579

2580

2581

(defun get-accounting-notes ()

2582

(bt:with-lock-held (*accounting-notes-lock*)

2583

(prog1 (coerce *accounting-notes* 'list)

2584

(fill *accounting-notes* nil)

2585

(setf (fill-pointer *accounting-notes*) 0))))

2586

2587

(defun accounting-note-count ()

2588

(length *accounting-notes*))

2589

2590

;;; thread introspection

2591

2592

(defparameter *algebra-idle-priority* 0)

2593

(defparameter *algebra-running-priority* nil) ; 3)

2594

2595

(defun thread-priority ()

2596

;; nyi

2597

nil)

2598

2599

(defun (setf thread-priority) (value)

2600

#+sbcl

2601

(when (and *algebra-running-priority* (zerop (sb-unix:unix-getuid)))

2602

(rdfcache:boost value))

2603

value)

2604

2605

2606

(defun thread-locked-p (thread)

2607

#-sbcl nil

2608

#+sbcl (eq thread (sb-thread:mutex-owner sb-c::**world-lock**)))

2609

2610

(defun list-queues ()

2611

(list *accounting-notes*

2612

*error-condition-channel*

2613

;; *thread-channel*

2614

*algebra-task-channel*

2615

*service-channel*))

2616

(defun list-thread-operations (&key (verbose nil))

2617

#+sbcl

2618

(loop for thread in (bt:all-threads)

2619

for operations = (if (thread-locked-p thread)

2620

'((:<?locked?>))

2621

                            (cons (list (sb-thread:symbol-value-in-thread '*task* thread nil))

2622

                                  (sb-thread:symbol-value-in-thread '*thread-operations* thread nil)))

2623

2624

when operations

2625

collect (if verbose

2626

(cons thread operations)

2627

(cons (bt:thread-name thread) (mapcar #'first operations))))

2628

#-sbcl

2629

`(:NYI ,verbose))

2630

2631

(defun trace-thread-operations (&key (interval 1) (duration nil) verbose)

2632

(loop with start = (get-universal-time)

2633

with last-operations = ()

2634

for operations = (list-thread-operations :verbose verbose)

2635

while (or (null duration)

2636

(< (get-universal-time) (+ start duration)))

2637

if (equalp last-operations operations)

2638

do (when interval (sleep interval))

2639

else do (progn (when operations

2640

(setf last-operations operations)

2641

                          (format *trace-output* "~&~:w~%~%" (cons (iso-time) operations))

2642

(finish-output *trace-output*))

2643

(when interval (sleep interval)))))

2644

2645

(defun backtrace-threads (&key name (start 0) (count most-positive-fixnum) (stream *trace-output*))

2646

(loop for th in (bt:all-threads)

2647

when (and (not (eq th (bt:current-thread)))

2648

(cond (name

2649

                          (string-equal (bt:thread-name th) name :end1 (min (length (bt:thread-name th)) (length name))))

2650

(t t)))

2651

collect (backtrace-thread th :start start :count count :stream stream)))

2652

2653

(defun backtrace-thread (thread &key (start 0) (count most-positive-fixnum) (stream *trace-output*))

2654

(let ((ok nil))

2655

(format stream "~%~%----------[~a ..." (bt:thread-name thread))

2656

(finish-output *trace-output*)

2657

(cond ((thread-locked-p thread)

2658

(format stream " locked]"))

2659

(t

2660

(handler-case

2661

(progn (bt:interrupt-thread thread

2662

#'(lambda ()

2663

                                              (format stream " : ~a" *task*)

2664

                                              (handler-case (print-stacktrace stream :start start :count count)

2665

                                                (error (c) (format stream "~%~%error in backtrace: ~a" c)))

2666

                                              (format stream "... ~a]----------~%" (bt:thread-name (bt:current-thread)))

2667

(finish-output stream)

2668

(setf ok t)))

2669

(dotimes (i 10 (format stream " uninterruptable]"))

2670

(when ok (return))

2671

(sleep .5)))

2672

(error (c) (format stream "~%~%error in interrupt-thread: ~a" c)))))

2673

thread))

2674

2675

(defun print-thread-operations (&key (stream *trace-output*) (verbose nil))

2676

(format stream "~&operations @gc: ~a~%" (list-thread-operations :verbose verbose))

2677

(values))

2678

2679

;(list-queues)

2680

;(setq *query-maximum-threads* nil)

2681

;(setq *agp-maximum-threads* 0)

2682

;(list-queries)

2683

;(list-thread-operations) ; :verbose t)

2684

;(trace-thread-operations)

2685

;(backtrace-threads :name "response")

2686

;(backtrace-threads :name "response" :start 16 :count 8)

2687

;(backtrace-threads :name "request" :start 16 :count 8)

2688

;(backtrace-threads :name "algebra" :start 16 :count 8)

2689

;(backtrace-threads :start 16 :count 16)

2690

;(backtrace-threads :name "response3" :start 16 :count 8)

2691

;(backtrace-threads :name "management" :start 16 :count 8)

2692

;(backtrace-threads :name "re" :start 16 :count 8)

2693

; (push 'print-thread-operations sb-ext:*after-gc-hooks*)

2694

;(dolist

2695

2696

#|

2697

2698

test sbcl timing:

2699

2700

(defun dt (fun)

2701

(multiple-value-bind (t-or-nil ut st) (sb-unix::unix-getrusage 0)

2702

(declare (ignore t-or-nil))

2703

(let ((r (funcall fun)))

2704

(multiple-value-bind (t-or-nil nut nst) (sb-unix::unix-getrusage 0)

2705

(declare (ignore t-or-nil))

2706

(values r (- nut ut) (- nst st))))))

2707

2708

(time (dt #'(lambda () (dotimes (x 1000000) (subseq "aaaa" 2)))))

2709

;;; turns out, that linux times to 10ms resolution only, while osx

2710

;;; appears to yield microsecond resolution values :

2711

;;; * (list (software-type) (multiple-value-list (sb-unix::unix-getrusage 0)))

2712

;;; ("Darwin" (T 876206 617965 0 0 0 0 0 0 0 1 5 0 0 14426 27 0))

2713

;;; v/s

2714

;;; * (list (software-type) (multiple-value-list (sb-unix::unix-getrusage 0)))

2715

;;; ("Linux" (T 20000 20000 0 0 0 0 6212 238 0 44952 0 0 0 0 263 2))

2716

2717

|#

2718

2719

;;;

2720

;;; expression utilities

2721

;;;

2722

;;; while solutions are represented as p-lists, a special equality predicate is used.

2723

;;; once they are just value sequences, the simpler alternative suffices

2724

2725

(defun plist-same-term-p (plist1 plist2)

2726

;; allow for atomic keys

2727

(if (and (consp plist1) (consp plist2))

2728

(locally (declare (optimize (speed 3) (safety 0)))

2729

(do ((plist1 (cdr plist1) (cdr plist1)) (plist2 (cdr plist2) (cdr plist2)))

2730

((or (null plist1) (null plist2))

2731

(and (null plist1) (null plist2)))

2732

(let ((value1 (pop plist1)) (value2 (pop plist2)))

2733

(unless (or (eql value1 value2)

2734

(spocq.e:same-term value1 value2))

2735

(return nil)))))

2736

(spocq.e:same-term plist1 plist2)))

2737

2738

(defun list-same-term-p (list1 list2)

2739

(if (and (consp list1) (consp list2))

2740

(locally (declare (optimize (speed 3) (safety 0))

2741

(type list list1 list2))

2742

(loop for value1 in list1

2743

unless (and list2 (spocq.e:same-term value1 (pop list2)))

2744

return nil

2745

finally (return (null list2))))

2746

(spocq.e:same-term list1 list2)))

2747

2748

(defun term-id-list-equalp (list1 list2)

2749

(if (and (consp list1) (consp list2))

2750

(locally (declare (optimize (speed 3) (safety 0))

2751

(type list list1 list2))

2752

(loop for value1 in list1

2753

unless (and list2 (= (the fixnum value1) (the fixnum (pop list2))))

2754

return nil

2755

finally (return (null list2))))

2756

(= (the fixnum list1) (the fixnum list2))))

2757

2758

(defun sb-impl-mix (x y) ; from sbcl:src;code;target-sxhash

2759

(declare (optimize (speed 3) (safety 0)))

2760

(declare (type (and fixnum unsigned-byte) x y))

2761

(let ((xy (+ (* x 3) y)))

2762

(logand most-positive-fixnum

2763

(logxor 441516657

2764

xy

2765

(ash xy -5)))))

2766

2767

(defun term-sxhash (term)

2768

(typecase term

2769

(fixnum (sxhash (the fixnum term)))

2770

(null (sxhash nil))

2771

(spocq:blank-node (sxhash (spocq:blank-node-label term)))

2772

(spocq:iri (sxhash (spocq:iri-lexical-form term)))

2773

(spocq:plain-literal (sb-impl-mix (sxhash (spocq:literal-lexical-form term))

2774

                                       (sxhash (spocq:plain-literal-language-tag term))))

2775

(spocq:atomic-typed-literal (sxhash (literal-value term)))

2776

(spocq:literal (sxhash (spocq:literal-lexical-form term)))

2777

(t (sxhash term))))

2778

2779

(defun term-id-list-psxhash (key)

2780

(declare (optimize (speed 3) (safety 0)))

2781

(typecase key

2782

;; could skip the keys for solution plists, but not for triples

2783

(cons (sb-impl-mix (sxhash (the fixnum (first key))) (term-id-list-psxhash (rest key))))

2784

(fixnum (sxhash (the fixnum key)))

2785

(t (term-sxhash key))))

2786

2787

(defun list-psxhash (key)

2788

(declare (optimize (speed 3) (safety 0)))

2789

(typecase key

2790

;; could skip the keys for solution plists, but not for triples

2791

(cons (sb-impl-mix (term-sxhash (first key)) (list-psxhash (rest key))))

2792

(t (term-sxhash key))))

2793

2794

(defun solution-equalp (s1 s2) (list-same-term-p s1 s2))

2795

2796

2797

#+digitool

2798

(progn

2799

(defun make-solution-cache (&key single-thread (size 64))

2800

(declare (ignore single-thread))

2801

(make-hash-table :test 'solution-equalp

2802

:hash-function 'list-psxhash

2803

:size size))

2804

(defun make-triple-cache (&key single-thread (size 64))

2805

(declare (ignore single-thread))

2806

(make-hash-table :test 'list-same-term-p :hash-function 'list-psxhash :size size))

2807

(defun make-term-id-cache (&key single-thread (size 64))

2808

(declare (ignore single-thread))

2809

(make-hash-table :test 'term-id-list-equalp

2810

:hash-function 'term-id-list-psxhash

2811

:size size))

2812

(defun (setf get-solution) (solution key-value cache)

2813

(setf (gethash key-value cache) solution))

2814

   (defun get-solution (solution cache &key (key nil) (key-value (if key (funcall key solution) solution)))

2815

(gethash key-value cache)))

2816

2817

#+lispworks

2818

(progn

2819

(defun make-solution-cache (&key (single-thread t) (size 64))

2820

(make-hash-table :test 'solution-equalp

2821

:hash-function 'list-psxhash

2822

:size size

2823

:single-thread single-thread))

2824

(defun make-triple-cache (&key (single-thread t)(size 64))

2825

(make-hash-table :test 'list-same-term-p

2826

:hash-function 'list-psxhash

2827

:size size

2828

:single-thread single-thread))

2829

(defun make-term-id-cache (&key (single-thread t) (size 64))

2830

(make-hash-table :test 'term-id-list-equalp

2831

:hash-function 'term-id-list-psxhash

2832

:size size

2833

:single-thread single-thread))

2834

(defun (setf get-solution) (solution key-value cache)

2835

(setf (gethash key-value cache) solution))

2836

   (defun get-solution (solution cache &key (key nil) (key-value (if key (funcall key solution) solution)))

2837

(gethash key-value cache)))

2838

2839

2840

#+sbcl

2841

(progn

2842

(sb-ext:define-hash-table-test solution-equalp list-psxhash)

2843

(defun make-solution-cache (&key (single-thread t) (size 64))

2844

(make-hash-table :test 'solution-equalp

2845

:size size

2846

:synchronized (not single-thread)))

2847

(sb-ext:define-hash-table-test list-same-term-p list-psxhash)

2848

(defun make-triple-cache (&key (single-thread t) (size 64))

2849

(make-hash-table :test 'list-same-term-p

2850

:size size

2851

:synchronized (not single-thread)))

2852

(sb-ext:define-hash-table-test term-id-list-equalp term-id-list-psxhash)

2853

(defun make-term-id-cache (&key (single-thread t) (size 64))

2854

(make-hash-table :test 'term-id-list-equalp

2855

:size size

2856

:synchronized (not single-thread)))

2857

(defun (setf get-solution) (solution key-value cache)

2858

(setf (gethash key-value cache) solution))

2859

(defun get-solution (key-value cache)

2860

(gethash key-value cache))

2861

2862

(defmacro with-locked-cache ((cache) &body body)

2863

`(sb-ext:with-locked-hash-table (,cache) ,@body)))

2864

2865

2866

#|

2867

nb. sxhash may not be the right function to use. specifically for sbcl it is definitely suboptimal.

2868

there, given that +max-hash-depthoid+ limits recursion to the first four element of the list,

2869

a hashtable used for a join or a distinct would degenerate to list comparison as soon

2870

as the first two bindings are the same. sp2b yields that already in q6 @10.

2871

2872

for example:

2873

2874

* (sxhash '(?::|name| "Lonce Jiron" ?::|author| _::|LonceJiron| ?::|yr| 1953 ?::|document|

2875

<http://localhost/publications/inprocs/Proceeding1/1953/Inproceeding15>

2876

?::|class| <http://localhost/vocabulary/bench/Inproceedings> ?::|author2|

2877

_::|KatrynVolmer| ?::|yr2| 1954 ?::|document2|

2878

<http://localhost/publications/inprocs/Proceeding1/1954/Inproceeding4>

2879

?::|class2| <http://localhost/vocabulary/bench/Inproceedings>))

2880

2881

152101437132019119

2882

* (sxhash '(?::|name| "Lonce Jiron" ?::|author| _::|LonceJiron| ?::|yr| 1953 ?::|document|

2883

<http://localhost/publications/inprocs/Proceeding1/1953/Inproceeding15>

2884

?::|class| <http://localhost/vocabulary/bench/Inproceedings> ?::|author2|

2885

_::|ValentinaTopia| ?::|yr2| 1950 ?::|document2|

2886

<http://localhost/publications/inprocs/Proceeding1/1950/Inproceeding19>

2887

?::|class2| <http://localhost/vocabulary/bench/Inproceedings>))

2888

2889

152101437132019119

2890

2891

as the variation appears at element 12

2892

|#

2893

2894

2895

(:documentation "blank nodes and skolemization"

2896

"blank nodes are created in two contexts: as pattern terms and as data terms

2897

in the former case, they need be unique within the document only, for which

2898

a task-specific counter suffices. for the latter purpose, they should be

2899

unique within the store. the generation takes to steps. first generate an

2900

eight character string, of which the first is a random letter and the

2901

remaining 7 are the result of random character encoded base 37. this is

2902

resolved avainst the store. if a node is alredy present, repeat the

2903

process. otherwise use it a data.

2904

re randomness: to use random as the basis for this, requires that the

2905

work with a random state is threadsafe. at least sbcl does not rebind it, so

2906

it must be ensured when threads are created.

2907

2908

wrt syntax turtle[4] allows initial alpha+_ followed by alphanumeric,

2909

rdf+xml allows an NCName, SPARQL[6] allows alpha+_ followed by alphanumeric

2910

plus some additions, n3 qname bnf[7] permits the same NCName with the a;phabetic initial

2911

character restriction, while the ntriples syntax[8] limits the subsequent

2912

characters to alphanumeric

2913

This generates initial alpha, followed by (alphanumeric+_)*7 where the '_'

2914

appears as left-padding.

2915

This is stricter than the SPARQL syntax - which applies to an explicit

2916

skolemization, which permits an initial digit , '.', and various other inclusions.

2917

2918

[1] : http://answers.semanticweb.com/questions/8336/what-is-skolemization

2919

[2] : http://web.ing.puc.cl/~marenas/publications/iswc11.pdf

2920

[3] : http://www.w3.org/2011/rdf-wg/track/issues/40

2921

2922

[4] : http://www.w3.org/TeamSubmission/turtle/#nodeID

2923

[5] : http://www.w3.org/TR/REC-rdf-syntax/#rdf-id

2924

[6] : http://www.w3.org/TR/2012/PR-sparql11-query-20121108/#rBLANK_NODE_LABEL

2925

[7] : http://www.w3.org/2000/10/swap/grammar/n3-ietf.txt

2926

[8] : http://www.w3.org/2001/sw/RDFCore/ntriples/

2927

")

2928

2929

(defun blank-node-global-prefix ()

2930

(or *blank-node-global-prefix*

2931

       (setq *blank-node-global-prefix* (aref "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz" (day-in-month)))))

2932

2933

(defun compute-blank-node-global-label (&optional (prefix nil))

2934

"cf. the ntriples syntax, which requires the '0', as '_' is not permitted.

2935

coerce to lower case, which leaves the upper case containing alphabetic for

2936

other sources."

2937

(let ((label-number (random *blank-node-global-label-limit*)))

2938

;; nb. (not (> (expt 36 6) (expt 16 8)))

2939

(format nil "~@[~a_~]~(~c~36,7,'0r_~36,7,'0r~)" prefix (blank-node-global-prefix) label-number

2940

(logand (get-internal-real-time) #xffffffff))))

2941

;; (compute-blank-node-global-label)

2942

2943

(defun cons-global-blank-node (&key (transaction *transaction*) (prefix nil))

2944

"construct and return a blank node which is globally unique. if a transaction

2945

is available, ensure this with respect to the store.

2946

the uniqueness test is global within the repository, and if a transaction is

2947

active, the node is interned."

2948

2949

(flet ((lookup-node (node)

2950

(cffi:with-foreign-objects ((%term '(:struct rdfcache::term)))

2951

(rdfcache::%clear-term %term)

2952

(unwind-protect

2953

(progn (set-optional-term %term node)

2954

(rdfcache:lookup-term-number %term))

2955

(clear-optional-term %term)))))

2956

(or (loop for count below 10

2957

do (let* ((label (compute-blank-node-global-label prefix))

2958

(node (spocq:make-blank-node label)))

2959

(when (null (lookup-node node))

2960

(when transaction

2961

(rdfcache-object-term-number transaction node))

2962

(return node))))

2963

(error "no unique blank node generated"))))

2964

2965

(defun skolemize-insertions-p ()

2966

2967

2968

(defun skolemize-encoding-p ()

2969

(plusp (length (blank-node-prefix))))

2970

2971

2972

(defun cons-blank-node (&optional (prefix (blank-node-prefix)))

2973

"construct and return a blank node unique within the context of the query.

2974

these are used in query patterns and in generated output. For insert operations,

2975

the stricter cons-global-blank-node is used, as it guarantees uniqueness within the store."

2976

2977

(intern-blank-node (concatenate 'string

2978

                                   (if (zerop (length prefix)) *blank-node-cons-prefix* prefix)

2979

(princ-to-string (next-blank-node-index)))))

2980

2981

(defun cons-sequence-uri ()

2982

"Construct and return an rdf sequence uri. Index the respective counter to ensure that

2983

numbers iterate across the domain within the context of a given query process."

2984

   (intern-term-aspects :uri (format nil "http://www.w3.org/1999/02/22-rdf-syntax-ns#_~d" (next-sequence-index)) nil nil))

2985

2986

(defun cons-sequence-number ()

2987

"Construct and return an rdf sequence number. Index the respective counter to ensure that

2988

numbers iterate across the domain within the context of a given query process."

2989

(next-sequence-index))

2990

2991

(defun variable-p (object)

2992

"true iff the object represents a variable."

2993

(and (symbolp object)

2994

(eq (symbol-package object) *variable-package*)))

2995

2996

(defun cons-variable (&optional (prefix ""))

2997

"construct an undistinguished variable"

2998

(cons-symbol *variable-package* "?" prefix (princ-to-string (next-variable-index))))

2999

 #+(or)                                  ; to get rid of undistingusihed variables (see below)

3000

(defun cons-variable (&optional (prefix ""))

3001

"construct an undistinguished variable"

3002

(cons-symbol *variable-package* "!" prefix (princ-to-string (next-variable-index))))

3003

3004

;;; characterize variables as to whether they are "real" or correspond to blank nodes - whether

3005

;;; from the original query expression or generated, eg. for property paths.

3006

;;; but, this would confuse things (deftype variable () (satisfies undistinguished-variable-p))

3007

3008

(defun undistinguished-variable-p (object)

3009

"true iff the object represents an undistinguished variable.

3010

wrt terminology: http://en.wikipedia.org/wiki/Conjunctive_query"

3011

(and (variable-p object)

3012

(let ((name (symbol-name object)))

3013

(and (> (length name) 0) (eql (char name 0) #\?)))))

3014

3015

(deftype undistinguished-variable () '(satisfies undistinguished-variable-p))

3016

3017

(defun undistinguished-variables (variables)

3018

(remove-if-not #'undistinguished-variable-p variables))

3019

3020

(defun distinguished-variable-p (object)

3021

"true iff the object represents an undistinguished variable."

3022

(and (variable-p object)

3023

(let ((name (symbol-name object)))

3024

(and (> (length name) 0) (not (eql (char name 0) #\?))))))

3025

3026

(deftype distinguished-variable () '(satisfies distinguished-variable-p))

3027

3028

(defun distinguished-variables (variables)

3029

(remove-if-not #'distinguished-variable-p variables))

3030

3031

3032

(defun variable-name (object)

3033

object)

3034

3035

3036

(defun make-variable (name)

3037

(intern name *variable-package*))

3038

3039

3040

(defgeneric expression-variables (expression)

3041

   (:documentation "Extract a list of the expression's variables. In general, this includes blank nodes as

3042

they can be bound bgp operations. Later operations may need to exclude them.")

3043

(:method ((expresion null))

3044

nil)

3045

(:method ((expression symbol))

3046

(when (variable-p expression)

3047

(list expression)))

3048

(:method ((expression cons))

3049

(union (expression-variables (first expression))

3050

(expression-variables (rest expression))))

3051

(:method ((expression t))

3052

nil))

3053

3054

(defun bindings-variables (bindings)

3055

   "Return the variable component of a binding. Allow a singleton binding as well as to a value form."

3056

(loop for form in bindings

3057

collect (etypecase form

3058

(cons (first form))

3059

(symbol form))))

3060

3061

(defun bindings-value-forms (bindings)

3062

"Return the value component of a binding. Allow a singleton binding as well as to a value form."

3063

(loop for form in bindings

3064

collect (etypecase form

3065

(cons (second form))

3066

(symbol form))))

3067

3068

(defun bindings-value-variables (bindings)

3069

"Return the variables from the value components of a binding.

3070

Allow a singleton binding as well as to a value form.

3071

Suppress any variable bound in the set"

3072

(loop for form in bindings

3073

collect (etypecase form (cons (second form)) (symbol (list form))) into expression-variables

3074

when (and (consp form) (not (eq (first form) (second form))))

3075

collect (first form) into local-variables

3076

finally (return (set-difference (expression-variables expression-variables) local-variables))))

3077

3078

(defgeneric expression-projected-variables (expression)

3079

(:method ((expression cons))

3080

(case (first expression)

3081

(spocq.a:|extend|

3082

(destructuring-bind (field-expression variable value-expression) (rest expression)

3083

(declare (ignore value-expression)) ; it cannot introduce variables

3084

(let ((field-variables (expression-projected-variables field-expression)))

3085

(if (find variable field-variables)

3086

field-variables

3087

(cons variable field-variables)))))

3088

(spocq.a:|triple|

3089

(remove-if-not #'distinguished-variable-p (rest expression)))

3090

(spocq.a:|project|

3091

;; a project adds at most the declared variables

3092

(third expression))

3093

(spocq.a:|select|

3094

(if (listp (third expression))

3095

;; a select adds either the declared or bound variables

3096

(labels ((select-variables (variables)

3097

(when variables

3098

(destructuring-bind (first . rest) variables

3099

(typecase first

3100

(keyword (select-variables (cdr rest)))

3101

(symbol (if (variable-p first)

3102

(cons first (select-variables rest))

3103

(select-variables rest)))

3104

(cons (cons (first first) (select-variables rest))))))))

3105

(select-variables (third expression)))

3106

;; or all from the field expression

3107

(expression-projected-variables (second expression))))

3108

(spocq.a:|bgp|

3109

(remove-duplicates

3110

(reduce #'append (rest expression) :key #'expression-projected-variables :initial-value nil)

3111

:from-end t))

3112

(spocq.a::|equivalents|

3113

(mapcar #'first (rest expression)))

3114

(spocq.a:|filter|

3115

(expression-projected-variables (rest expression)))

3116

(spocq.a:|bindings|

3117

(third expression))

3118

(spocq.a:|slice|

3119

(expression-projected-variables (second expression)))

3120

(spocq.a:|declare|

3121

())

3122

(spocq.a:|exists|

3123

())

3124

(spocq.a:=

3125

())

3126

(t

3127

(if (and (variable-p (first expression))

3128

(consp (rest expression))

3129

(null (cddr expression)))

3130

;; if it's a binding, just the bound variable

3131

(list (first expression))

3132

;; anything else adds everything present

3133

(remove-duplicates (reduce #'append expression :key #'expression-projected-variables)

3134

:from-end t)))))

3135

(:method ((expression t))

3136

(expression-variables expression)))

3137

3138

3139

(defgeneric operation-free-variables (operation arguments)

3140

(:documentation "returns all variables which are free in the form.

3141

in distinction to projected variables this includes those in an exists, excludes those bound by

3142

an extend, values, or select form. the variables from a bgp are included as well, as they are

3143

also subject to dynamic bindings.")

3144

3145

(:method ((operation (eql 'spocq.a:|bgp|)) arguments)

3146

(reduce #'append arguments :key #'expression-free-variables :initial-value nil))

3147

3148

(:method ((operation (eql 'spocq.a:|bindings|)) arguments)

3149

"The vlaue forms are constant"

3150

())

3151

3152

(:method ((operation (eql 'spocq.a:|declare|)) arguments)

3153

())

3154

3155

(:method ((operation (eql 'spocq.a:|extend|)) arguments)

3156

     "An extend form can have free variables in both the base field and the binding value expression.

3157

Those in the value expression must be netted against thos eprojected from the field.

3158

The variable has no consequence."

3159

(destructuring-bind (field-expression variable value-expression) arguments

3160

(declare (ignore variable))

3161

(union (set-difference (expression-variables value-expression)

3162

(expression-projected-variables field-expression))

3163

(expression-free-variables field-expression))))

3164

3165

(:method ((operation (eql 'spocq.a:|extend|)) arguments)

3166

     "An extent leaves free anything which is not projected. The binding variable ha no immediate effect."

3167

(destructuring-bind (field variable value . options) arguments

3168

(declare (ignore variable options))

3169

(set-difference (union (expression-free-variables value)

3170

(expression-free-variables field))

3171

(expression-projected-variables field))))

3172

3173

(:method ((operation (eql 'spocq.a::|equivalents|)) (arguments t))

3174

())

3175

3176

(:method ((operation (eql 'spocq.a:|filter|)) arguments)

3177

(destructuring-bind (field predicate . options) arguments

3178

(declare (ignore options))

3179

(union (set-difference (expression-free-variables predicate) (expression-projected-variables field))

3180

(expression-free-variables field))))

3181

3182

(:method ((operation (eql 'spocq.a:|project|)) arguments)

3183

(operation-free-variables 'spocq.a:|select| arguments))

3184

3185

(:method ((operation (eql 'spocq.a:|select|)) arguments)

3186

(labels ((projection-free-variables (projection projected free)

3187

                ;; return as two values the projetion bindings and the values' free variables

3188

(if projection

3189

(destructuring-bind (first . rest) projection

3190

(typecase first

3191

(keyword (projection-free-variables (cdr rest) projected free))

3192

(symbol (if (variable-p first)

3193

                                    (projection-free-variables rest (cons first projected) free)

3194

                                    (projection-free-variables rest projected free)))

3195

(cons (projection-free-variables rest

3196

                                                    (cons (first first) projected)

3197

                                                    (set-difference (expression-variables (second first)) projected)))

3198

(t (projection-free-variables rest projected free))))

3199

free)))

3200

;; those varibles free in the projection clause, but not projected from the field

3201

(set-difference (projection-free-variables (second arguments) nil

3202

                                                  (expression-free-variables (first arguments)))

3203

(expression-projected-variables (first arguments)))))

3204

3205

(:method ((operation (eql 'spocq.a:|slice|)) arguments)

3206

(expression-free-variables (first arguments)))

3207

3208

(:method ((operation (eql 'spocq.a:|triple|)) arguments)

3209

"A triple allows that any variable present can be dynamiclly bound."

3210

(loop for elt in arguments for i below 3

3211

when (distinguished-variable-p elt) collect elt))

3212

3213

(:method ((operation t) arguments)

3214

(reduce #'append arguments :key #'expression-free-variables)))

3215

3216

3217

(defgeneric expression-free-variables (expression)

3218

(:method ((expression symbol))

3219

;; Allow any variable

3220

;; - the non-distinguished cases is handled for bgp forms in isolation

3221

;; - having generates a ?::?having-xxx variable for each constraint

3222

(when (variable-p expression)

3223

(list expression)))

3224

(:method ((expression cons))

3225

(operation-free-variables (first expression) (rest expression)))

3226

(:method ((expression t))

3227

nil))

3228

3229

(defgeneric operation-matched-variables (operation arguments)

3230

(:documentation "returns all variables which are from a bgp are included as well.")

3231

3232

(:method ((operation (eql 'spocq.a:|bgp|)) arguments)

3233

(reduce #'append arguments :key #'expression-matched-variables :initial-value nil))

3234

3235

(:method ((operation (eql 'spocq.a:|triple|)) arguments)

3236

"any variable present"

3237

(loop for elt in arguments for i below 3

3238

when (variable-p elt) collect elt))

3239

3240

(:method ((operation t) arguments)

3241

(reduce #'append arguments :key #'expression-matched-variables)))

3242

3243

(defgeneric expression-matched-variables (expression)

3244

(:method ((expression cons))

3245

(operation-matched-variables (first expression) (rest expression)))

3246

(:method ((expression t))

3247

nil))

3248

3249

(defun expression-free-dimensions (expression)

3250

"Return the expression's free variables, ordered and deduplicated"

3251

(sort (remove-duplicates (copy-list (expression-free-variables expression))) #'string-lessp))

3252

3253

3254

(defgeneric expression-dimensions (expression)

3255

;; limit the dimensions to those which are actually projected !

3256

(:method ((expression t)) (sort (copy-list (expression-projected-variables expression)) #'string-lessp))

3257

(:method ((expression solution-field)) (solution-field-dimensions expression)))

3258

3259

#+(or) ;; superseded by bgp-projected-dimensions

3260

(defun bgp-dimensions (statements)

3261

"for a basic graph pattern return both distinguished and non-distinguished variables

3262

in order the anonymous variable be available to join."

3263

(case *class.repository*

3264

(rdfcache-matrix-repository

3265

;; a bgp applied as a matrix yields the complete join dimensionality of the

3266

;; patterns - including duplicates and constants from a single pattern

3267

(when statements

3268

(reduce #'join-result-dimensions (loop for pattern in statements

3269

                                               when (triple-form-p pattern)

3270

                                               collect (remove-if-not #'variable-p (statement-terms pattern)))

3271

:from-end t)))

3272

(t

3273

(sort (expression-variables statements) #'string-lessp))))

3274

3275

(defun bgp-projected-dimensions (body)

3276

(if (consp (first body))

3277

(let ((variables ()))

3278

(loop for statement-pattern in body

3279

do (loop for variable in (bgp-statement-projected-dimensions statement-pattern)

3280

do (pushnew variable variables)))

3281

(sort variables #'string-lessp))))

3282

3283

(defun bgp-statement-projected-dimensions (pattern)

3284

;; filters and identifiers cannot contribute projection

3285

(cond ((triple-form-p pattern)

3286

(let ((terms (statement-terms pattern)))

3287

(destructuring-bind (s p o &optional g) terms

3288

(declare (ignore s o))

3289

(cond ((active-verb-p p) ;; the subject and object are artefacts of the lists

3290

(if (variable-p g)

3291

(cons g (active-verb-results p))

3292

(active-verb-results p)))

3293

(t

3294

(loop for term in terms

3295

when (variable-p term)

3296

collect term))))))

3297

((graph-form-p pattern)

3298

(let ((graph (second pattern)))

3299

(when (variable-p graph)

3300

(list graph))))))

3301

3302

3303

3304

3305

3306

3307

;;; x5 faster, relative to loop or find,

3308

(defun bgp-pattern-type (statements)

3309

(some #'(lambda (s) (and (consp s)

3310

(eq (pop s) 'spocq.a:|triple|)

3311

(eq (first (setf s (cdr s))) |rdf|:|type|)

3312

(second s)))

3313

statements))

3314

3315

(defun bgp-pattern-predicates (statements)

3316

(loop for statement in statements

3317

when (triple-form-p statement)

3318

collect (statement-predicate statement)))

3319

3320

(defun bgp-pattern-subject (statements)

3321

(let ((pattern-subject ()))

3322

(loop for statement in statements

3323

when (triple-form-p statement)

3324

do (let ((subject (statement-subject statement)))

3325

(if (null pattern-subject)

3326

(setf pattern-subject subject)

3327

(unless (equalp pattern-subject subject)

3328

(return nil))))

3329

finally (return pattern-subject))))

3330

3331

3332

;;; derive expression variable with scoping

3333

3334

(defgeneric parse-expression-variables (expression)

3335

(:documentation "given a symbolic algebra expression, return as several values the

3336

variable sets

3337

all : all distinguished variables;

3338

bound : all variables which are bound, in their outermost scope,

3339

in either an extend or a select form;

3340

free : all variables which are not bound in their outermost scope. this may include

3341

projection references, but not projection bindings

3342

projected : all variables which appear in a select projection, in their outermost scope,

3343

whether simple references or bindings, or, absent a projection form all free variables.

3344

3345

delegate to parse-operation-variables for the operator-specific logic.")

3346

3347

(:method ((expression symbol))

3348

;; Allow any variable

3349

;; - the non-distinguished cases is handled for bgp forms in isolation

3350

;; - having generates a ?::?having-xxx variable for each constraint

3351

(when (variable-p expression)

3352

(list expression)))

3353

(:method ((expression cons))

3354

(parse-operation-variables (first expression) (rest expression)))

3355

(:method ((generator solution-generator))

3356

(let ((dimensions (solution-generator-dimensions generator)))

3357

(values dimensions nil dimensions dimensions)))

3358

(:method ((expression t))

3359

nil))

3360

3361

(macrolet ((collecting-variables ((elt list) form)

3362

`(let ((all ())

3363

(bound ())

3364

(free ())

3365

(projected ()))

3366

(loop for ,elt in ,list

3367

do (multiple-value-bind (arg-all arg-bound arg-free arg-projected)

3368

,form

3369

(setf all (union all arg-all)

3370

bound (union bound arg-bound)

3371

free (union free arg-free)

3372

projected (union projected arg-projected))))

3373

(values all bound free projected))))

3374

3375

(defgeneric parse-operation-variables (operation arguments)

3376

(:documentation "analyse the given operator arguments according to binding and scoping

3377

rules and return as several values the variable sets: all bound free projected.")

3378

3379

(:method ((operation (eql 'spocq.a:|bgp|)) arguments)

3380

"all free variables in any triple are free in the bgp"

3381

(collecting-variables (pattern arguments) (parse-expression-variables pattern)))

3382

;;; (parse-expression-variables (parse-sparql "select * where {?s ?p _:test . _:test ?p2 ?o2}"))

3383

3384

3385

(:method ((operation (eql 'spocq.a:|bindings|)) arguments)

3386

"The variables are bound, while the value forms are constant."

3387

(destructuring-bind (solutions variables) arguments

3388

(declare (ignore solutions))

3389

(values variables variables nil nil)))

3390

;;; (parse-expression-variables (parse-sparql "select * where {?s ?p _:test . values ?z { 1 2 }}"))

3391

;;; (parse-expression-variables (parse-sparql "select * where {?s ?p _:test . values ?p { 1 2 }}"))

3392

3393

(:method ((operation (eql 'spocq.a:|declare|)) arguments)

3394

nil)

3395

3396

(:method ((operation (eql 'spocq.a::|equivalents|)) (arguments t))

3397

nil)

3398

3399

(:method ((operation (eql 'spocq.a:|extend|)) arguments)

3400

     "An extend form can have free variables in both the base field and the binding value expression.

3401

Those in the value expression must be netted against those projected from the field.

3402

The variable, if present, is then eliminated, as that would be am error."

3403

(destructuring-bind (field-expression variable value-expression) arguments

3404

(multiple-value-bind (field-all field-bindings field-free field-projection)

3405

(parse-expression-variables field-expression)

3406

(multiple-value-bind (value-all value-bindings value-free value-projection)

3407

(parse-expression-variables value-expression)

3408

(when value-bindings

3409

(log-debug "pov: binding in value form: ~s: ~s" value-bindings value-expression))

3410

(when value-bindings

3411

             (log-debug "pov: projection in value form: ~s: ~s" value-projection value-expression))

3412

;; do not check the new binding constraint here

3413

(pushnew variable field-bindings)

3414

(values (union field-all value-all)

3415

field-bindings

3416

(union field-free value-free)

3417

field-projection)))))

3418

 ;;; (parse-expression-variables (parse-sparql "select * where {  {?s ?a ?b} . bind (1 as ?a) . bind (2 as ?b) . }"))

3419

3420

(:method ((operation (eql 'spocq.a:|filter|)) arguments)

3421

(destructuring-bind (field predicate . options) arguments

3422

(declare (ignore options))

3423

(multiple-value-bind (field-all field-bindings field-free field-projection)

3424

(parse-expression-variables field)

3425

(multiple-value-bind (predicate-all predicate-bindings predicate-free predicate-projection)

3426

(parse-expression-variables predicate)

3427

(declare (ignore predicate-bindings predicate-projection))

3428

(values (union field-all predicate-all)

3429

                   ;; no binding from a predicate subexpression (eg exists) can be apparent

3430

field-bindings

3431

(union field-free predicate-free)

3432

                   ;; no projection from a predicate subexpression (eg exists) can be apparent

3433

field-projection)))))

3434

;;; (parse-expression-variables (parse-sparql "select * where { {?s ?a ?b} . filter(1 = ?b) . }"))

3435

 ;;; (parse-expression-variables (parse-sparql "select * where { {?s ?a ?b} . filter(exists {?x ?a ?b}) . }"))

3436

 ;;; (parse-expression-variables (parse-sparql "select * where { {?s ?a ?b} . filter(exists {select ?x where {?x ?a ?b}}) . }"))

3437

3438

(:method ((operation (eql 'spocq.a:|join|)) arguments)

3439

(multiple-value-bind (first-all first-bindings first-free first-projection)

3440

(parse-expression-variables (first arguments))

3441

(multiple-value-bind (second-all second-bindings second-free second-projection)

3442

(parse-expression-variables (second arguments))

3443

(let ((join-free (union first-free second-free)))

3444

(values (union first-all second-all)

3445

(set-difference (union first-bindings second-bindings) join-free)

3446

join-free

3447

(union first-projection second-projection))))))

3448

3449

(:method ((operation (eql 'spocq.a:|leftjoin|)) arguments)

3450

(parse-operation-variables 'spocq.a:|join| arguments))

3451

3452

(:method ((operation (eql 'spocq.a:|project|)) arguments)

3453

(destructuring-bind (field dimensions . options) arguments

3454

(declare (ignore options))

3455

(multiple-value-bind (field-all field-bindings field-free field-projection)

3456

(parse-expression-variables field)

3457

(declare (ignore field-projection))

3458

(values field-all ;; dimensions must be in the field

3459

field-bindings

3460

field-free

3461

dimensions))))

3462

3463

(:method ((operation (eql 'spocq.a:|select|)) arguments)

3464

(destructuring-bind (field selection-specification . options) arguments

3465

(declare (ignore options))

3466

(loop (if (keywordp (first selection-specification))

3467

(setf selection-specification (cddr selection-specification))

3468

(return)))

3469

(multiple-value-bind (field-all field-bindings field-free field-projection)

3470

(parse-expression-variables field)

3471

(declare (ignore field-projection)) ;; is superseded

3472

(loop for selection in selection-specification

3473

with selection-projection = ()

3474

do (typecase selection

3475

(symbol (when (variable-p selection)

3476

(pushnew selection selection-projection)))

3477

(cons (destructuring-bind (variable value) selection

3478

(pushnew variable field-bindings)

3479

(pushnew variable selection-projection)

3480

                        (multiple-value-bind (value-all value-bindings value-free value-projection)

3481

                                             (parse-expression-variables value)

3482

(setf field-all (union value-all field-all))

3483

                          (setf field-bindings (union field-bindings value-bindings)) ;; should not be any

3484

(when (intersection field-free value-bindings)

3485

(log-debug "pov: free variable as bindings: ~s" value))

3486

(setf field-free (union field-free value-free))

3487

(when value-projection

3488

                            (log-debug "pov: projection variable in value: ~s" value)))))

3489

(t ))

3490

finally (return (values field-all

3491

field-bindings

3492

                                   ;; the free variables are reduced by the bindings

3493

(set-difference field-free field-bindings)

3494

selection-projection))))))

3495

3496

(:method ((operation (eql 'spocq.a:|service|)) arguments)

3497

(parse-expression-variables (first arguments)))

3498

3499

(:method ((operation (eql 'spocq.a:|slice|)) arguments)

3500

(parse-expression-variables (first arguments)))

3501

3502

(:method ((operation (eql 'spocq.a:|triple|)) arguments)

3503

"All distinguished variable present in a triple is free and can be dynamiclly bound.

3504

The are also projected."

3505

(let ((all ()))

3506

(loop for elt in arguments for i below 3

3507

when (distinguished-variable-p elt)

3508

do (pushnew elt all))

3509

(values all nil all all)))

3510

3511

(:method ((operation (eql 'spocq.a:|union|)) arguments)

3512

(parse-operation-variables 'spocq.a:|join| arguments))

3513

3514

(:method ((operation t) arguments)

3515

(collecting-variables (argument arguments) (parse-expression-variables argument))

3516

)))

3517

3518

3519

3520

(defun expression-blank-nodes (expression)

3521

(let ((nodes ()))

3522

(labels ((collect (expression)

3523

(cond ((null expression) )

3524

((spocq:blank-node-p expression)

3525

(pushnew expression nodes :test #'equalp))

3526

((consp expression)

3527

(collect (first expression))

3528

(collect (rest expression)))

3529

(t nil))))

3530

(collect expression))

3531

nodes))

3532

3533

(defun expression-undistinguished-variables (expression)

3534

(let ((variables ()))

3535

(labels ((collect (expression)

3536

(cond ((null expression) )

3537

((undistinguished-variable-p expression)

3538

(pushnew expression variables))

3539

((consp expression)

3540

(collect (first expression))

3541

(collect (rest expression)))

3542

(t nil))))

3543

(collect expression))

3544

variables))

3545

3546

(defun expression-resources (expression)

3547

(declare (ftype function spocq.e:iri-p))

3548

(let ((result ()))

3549

(labels ((collect (expression)

3550

(cond ((null expression) )

3551

((iri-p expression)

3552

(pushnew expression result))

3553

((consp expression)

3554

(collect (first expression))

3555

(collect (rest expression)))

3556

(t nil))))

3557

(collect expression))

3558

result))

3559

3560

3561

(defun spocq.e:constantp (object)

3562

"Return true iff the term is a constant.

3563

This includes all boxed term structures, native strings and numbers, and symbols which represent

3564

uri."

3565

3566

(typecase object

3567

(spocq:term (not (spocq:blank-node-p object)))

3568

(string t)

3569

(number t)

3570

(symbol (iri-p object))))

3571

3572

(defun spocq.e:literalp (object)

3573

"Return true iff the term is a literal.

3574

This includes boxed literal structures and native strings and numbers."

3575

3576

(typecase object

3577

(spocq:literal t)

3578

(string t)

3579

(number t)))

3580

3581

3582

(defun expression-constants (expression)

3583

(let ((result ()))

3584

(labels ((collect (expression)

3585

(cond ((null expression) )

3586

((spocq.e:constantp expression)

3587

(pushnew expression result :test #'spocq.e:|=|))

3588

((consp expression)

3589

(collect (first expression))

3590

(collect (rest expression)))

3591

(t nil))))

3592

(collect expression))

3593

result))

3594

3595

3596

(defun expression-algebra-operators (expression &key (unique-p t) (triples-p nil))

3597

(let ((result ()))

3598

(labels ((collect (expression)

3599

(cond ((null expression) )

3600

((consp expression)

3601

(destructuring-bind (op . args) expression

3602

(if (and (symbolp op)

3603

(eq (symbol-package op) *ALGEBRA-PACKAGE*)

3604

(or (fboundp op) (macro-function op)

3605

                                      (and triples-p (eq op 'spocq.a:|triple|))))

3606

(if unique-p

3607

(pushnew (first expression) result)

3608

(push (first expression) result))

3609

(collect (first expression)))

3610

(dolist (elt args) (collect elt))))

3611

(t nil))))

3612

(collect expression))

3613

result))

3614

3615

(defun expression-algebra-expressions (expression &key (triples-p nil) (operators nil))

3616

(let ((result ()))

3617

(labels ((collect (expression)

3618

(cond ((null expression) )

3619

((consp expression)

3620

(destructuring-bind (op . args) expression

3621

(if (and (symbolp op)

3622

(eq (symbol-package op) *ALGEBRA-PACKAGE*)

3623

(or (null operators) (member op operators))

3624

(or (fboundp op) (macro-function op)

3625

                                      (and triples-p (eq op 'spocq.a:|triple|))))

3626

(push expression result)

3627

(collect op))

3628

(dolist (elt args) (collect elt))))

3629

(t nil))))

3630

(collect expression))

3631

result))

3632

3633

(defun expression-operators (expression)

3634

(let ((result ()))

3635

(labels ((collect (expression)

3636

(cond ((null expression) )

3637

((consp expression)

3638

(destructuring-bind (op . args) expression

3639

(if (and (symbolp op)

3640

(or (fboundp op) (macro-function op)))

3641

(pushnew (first expression) result)

3642

(collect (first expression)))

3643

(dolist (elt args) (collect elt))))

3644

(t nil))))

3645

(collect expression))

3646

result))

3647

3648

(defgeneric expression-form-p (source predicate)

3649

(:method ((source list) (predicate function))

3650

(let ((forms ()))

3651

(labels ((walk (form)

3652

(cond ((funcall predicate form)

3653

(push form forms))

3654

((consp form)

3655

(map nil #'walk form)))))

3656

(walk source)

3657

forms)))

3658

(:method ((source t) predicate)

3659

;; from test;sore;encoding;ssf-sparql

3660

(expression-form-p (ignore-errors (parse-sparql source)) predicate))

3661

3662

(:method ((source t) (operator symbol))

3663

(expression-form-p source

3664

#'(lambda (form) (and (consp form)

3665

                                              (eq (first form) operator))))))

3666

3667

(defun expression-service-forms (expression)

3668

(expression-form-p expression #'service-form-p))

3669

3670

(defun expression-select-forms (expression)

3671

(expression-form-p expression #'select-form-p))

3672

3673

(defun expression-table-forms (expression)

3674

(expression-form-p expression #'table-form-p))

3675

3676

(defparameter *expression-pattern-statements-graph* nil)

3677

3678

(defun expression-pattern-statements (expression)

3679

"Walk an expression and return the pattern statements.

3680

Where a bgp is within the scope of a graph, its statements are transformed into quads.

3681

Otherwise, the literal triples suffice."

3682

3683

(let ((statements ())

3684

(*expression-pattern-statements-graph* nil))

3685

(labels ((collect-statements (expression)

3686

(cond ((bgp-form-p expression)

3687

(loop for statement in (rest expression)

3688

when (triple-form-p statement)

3689

do (push (if *expression-pattern-statements-graph*

3690

`(spocq.a:|quad| ,@(rest statement)

3691

                                                         ,(if (variable-p *expression-pattern-statements-graph*)

3692

nil

3693

                                                            *expression-pattern-statements-graph*))

3694

statement)

3695

statements))

3696

nil)

3697

((graph-form-p expression)

3698

(let ((*expression-pattern-statements-graph* (second expression)))

3699

(walk-tree #'collect-statements (third expression))

3700

nil))

3701

(t

3702

expression))))

3703

(declare (dynamic-extent #'collect-statements))

3704

(walk-tree #'collect-statements expression))

3705

(remove-duplicates statements :test #'equal)))

3706

3707

(defun expression-pattern-predicates (expression)

3708

(remove-duplicates (mapcar #'statement-predicate (expression-pattern-statements expression))))

3709

3710

(defun expression-pattern-classes (expression)

3711

"Walk an expression and return the pattern classes.

3712

Each pattern collects the respective statement predicate for a given subject.

3713

Graph scope has no effect."

3714

3715

(let ((classes ()))

3716

(labels ((collect-statements (expression)

3717

(cond ((bgp-form-p expression)

3718

(loop for statement in (rest expression)

3719

with bgp-classes = ()

3720

                         when (and (triple-form-p statement) (not (eq (statement-predicate statement) |rdf|:|type|)))

3721

                         do (pushnew (statement-predicate statement) (getf bgp-classes (statement-subject statement)))

3722

finally (loop for (class predicates) on bgp-classes by #'cddr

3723

do (push predicates classes)))

3724

nil)

3725

(t

3726

expression))))

3727

(declare (dynamic-extent #'collect-statements))

3728

(walk-tree #'collect-statements expression))

3729

(remove-duplicates classes :test #'(lambda (c1 c2) (null (set-exclusive-or c1 c2))))))

3730

3731

(defun expression-triples (expression)

3732

"Walk an expression and return the literal triples - that is w/o graph augmentation."

3733

3734

(let ((statements ())

3735

(*expression-pattern-statements-graph* nil))

3736

(labels ((collect-statements (expression)

3737

(cond ((bgp-form-p expression)

3738

(dolist (sub-expression (rest expression))

3739

(collect-statements sub-expression)))

3740

((triple-form-p expression)

3741

(push expression statements))

3742

(t

3743

expression))))

3744

(declare (dynamic-extent #'collect-statements))

3745

(walk-tree #'collect-statements expression))

3746

(remove-duplicates statements :test #'equal)))

3747

3748

(defgeneric expression-bgps (source)

3749

(:method ((source list))

3750

(let ((bgps ()))

3751

(labels ((walk (form)

3752

(cond ((bgp-form-p form)

3753

(push form bgps))

3754

((consp form)

3755

(map nil #'walk form)))))

3756

(walk source)

3757

bgps)))

3758

(:method ((source t))

3759

;; from test;sore;encoding;ssf-sparql

3760

(expression-bgps (parse-sparql source))))

3761

3762

3763

(defun aggregate-expression-p (expression)

3764

(labels ((test-for-aggregate-op (expression)

3765

(cond ((consp expression)

3766

(if (aggregate-operator-p (first expression))

3767

(return-from aggregate-expression-p t)

3768

(map nil #'test-for-aggregate-op expression)))

3769

(t nil))))

3770

(test-for-aggregate-op expression))

3771

nil)

3772

3773

(defun aggregate-operator-p (object)

3774

3775

spocq.a:|max| spocq.a:|min|

3776

spocq.a:|sample| spocq.a:|std| spocq.a:|sum|))

3777

t))

3778

3779

(defun temporal-expression-p (e)

3780

"Return true iff the argument is an expression which is a logical conjunction of temporal relations

3781

drawn from the OWL time ontology."

3782

(and (consp e)

3783

(destructuring-bind (op . args) e

3784

(case op

3785

((spocq.a:|and| spocq.a:|or| spocq.a:|not| spocq.a:|exprlist|

3786

             ORG.DATAGRAPH.SPOCQ.ALGEBRA:|\|\|| ORG.DATAGRAPH.SPOCQ.ALGEBRA:|&&| ORG.DATAGRAPH.SPOCQ.ALGEBRA:|!|)

3787

(some #'temporal-expression-p args))

3788

(t

3789

             (and (symbolp op) (eq (symbol-package op) (load-time-value (symbol-package '|time|:|intervalAfter|)))))))))

3790

3791

(defun temporal-value-p (e)

3792

(and (consp e)

3793

(destructuring-bind (op . args) e

3794

(declare (ignore args))

3795

3796

3797

(defgeneric revision-interval-end-record (version)

3798

(:method ((version t)) nil)

3799

(:method ((version spocq:revision-interval))

3800

(rlmdb:revision-record (spocq:revision-interval-end version))))

3801

3802

(defgeneric revision-interval-start-record (version)

3803

(:method ((version t)) nil)

3804

(:method ((version spocq:revision-interval))

3805

(rlmdb:revision-record (spocq:revision-interval-start version))))

3806

3807

(defgeneric revision-interval-end-date-time (version)

3808

(:method ((version t)) nil)

3809

(:method ((version spocq:revision-interval))

3810

(let ((record (revision-interval-end-record version)))

3811

(etypecase record

3812

(null nil)

3813

(rlmdb:revision-record (rlmdb:revision-record-date-time record))))))

3814

(defgeneric revision-interval-end-ordinal (version)

3815

(:method ((version t)) nil)

3816

(:method ((version spocq:revision-interval))

3817

(let ((record (revision-interval-end-record version)))

3818

(etypecase record

3819

(null nil)

3820

(rlmdb:revision-record (rlmdb:revision-record-ordinal record))))))

3821

(defgeneric revision-interval-end-uuid (version)

3822

(:method ((version t)) nil)

3823

(:method ((version spocq:revision-interval))

3824

(let ((record (revision-interval-end-record version)))

3825

(etypecase record

3826

(null nil)

3827

(rlmdb:revision-record (rlmdb:revision-record-uuid record))))))

3828

3829

(defgeneric revision-interval-start-date-time (version)

3830

(:method ((version t)) nil)

3831

(:method ((version spocq:revision-interval))

3832

(let ((record (revision-interval-start-record version)))

3833

(etypecase record

3834

(null nil)

3835

(rlmdb:revision-record (rlmdb:revision-record-date-time record))))))

3836

(defgeneric revision-interval-start-ordinal (version)

3837

(:method ((version t)) nil)

3838

(:method ((version spocq:revision-interval))

3839

(let ((record (revision-interval-start-record version)))

3840

(etypecase record

3841

(null nil)

3842

(rlmdb:revision-record (rlmdb:revision-record-ordinal record))))))

3843

(defgeneric revision-interval-start-uuid (version)

3844

(:method ((version t)) nil)

3845

(:method ((version spocq:revision-interval))

3846

(let ((record (revision-interval-start-record version)))

3847

(etypecase record

3848

(null nil)

3849

(rlmdb:revision-record (rlmdb:revision-record-uuid record))))))

3850

3851

3852

3853

(defun map-tree (function tree)

3854

"Copy the tree under the control of the mapped function.

3855

If it returns a given node, copy that node recursively. If it returns some other value,

3856

replace the node with that value."

3857

(declare (dynamic-extent function))

3858

3859

(flet ((map-element (e) (map-tree function e)))

3860

(declare (dynamic-extent #'map-element))

3861

(let ((replacement (funcall function tree)))

3862

(if (eq replacement tree)

3863

(typecase tree

3864

(cons (cons (map-tree function (first tree))

3865

(map-tree function (rest tree))))

3866

(string tree)

3867

(vector (map 'vector #'map-element tree))

3868

(t tree))

3869

replacement))))

3870

3871

3872

(defun replace-values-data (sse values-data &key (if-does-not-exist :error))

3873

"Substitute the bindings of a values clause into the matching form in the query.

3874

This applies the bindings by rewriting the query.

3875

The current implementation performs the substitution in-line, while evaluating

3876

the bindings form.

3877

(see spocq.e:stream-bindings)"

3878

(destructuring-bind (values-data-values-field values-data-dimensions) values-data

3879

(let* ((substitutions 0)

3880

(result (map-tree #'(lambda (form)

3881

(or (and (bindings-form-p form)

3882

                                           (destructuring-bind (op form-value-field form-dimensions) form

3883

                                             (declare (ignore form-value-field))

3884

                                             (when (equal form-dimensions values-data-dimensions)

3885

(incf substitutions)

3886

                                               `(,op ,values-data-values-field ,values-data-dimensions))))

3887

form))

3888

sse)))

3889

(unless (plusp substitutions)

3890

(ecase if-does-not-exist

3891

           (:error (spocq.e:request-error "no values clause present for request values variables: ~a"

3892

values-data-dimensions))

3893

((nil))))

3894

result)))

3895

3896

(defgeneric bind-sparql-expression (sse bindings)

3897

(:documentation

3898

"rewrite a query sse form to replace any variables present in the bindings with their values.

3899

this applies to pattern variables and select, aggregation or filter expressions only.

3900

The intent is to propagate bindings through to service locations with the precedence

3901

1. constants in the expression

3902

2. supplied bindings - including new dimensions

3903

the latter intend to cause request bindings to precede any sip values (see ")

3904

(:method (sse (bindings cons))

3905

(labels ((bind-bindings (variables)

3906

(loop for binding in variables

3907

collect (typecase binding

3908

                            (cons (cons (first binding) (map-tree #'bind-form (rest binding))))

3909

(t (let ((value (rest (assoc binding bindings))))

3910

(if value (list binding value) binding))))))

3911

(bind-form (form)

3912

(if (consp form)

3913

(case (first form)

3914

((spocq.a:|triple| spocq.a:|quad|)

3915

(sublis bindings form))

3916

(spocq.a:|select|

3917

                               (destructuring-bind (op field variables &rest args) form

3918

`(,op ,(map-tree #'bind-form field)

3919

,(when (consp variables)

3920

                                          (append (loop for first = (first variables)

3921

                                                    until (not (keywordp first))

3922

collect first

3923

                                                    collect (ecase (pop variables)

3924

                                                              (:having (sublis bindings (pop variables)))

3925

                                                              (:group-by (bind-bindings (pop variables)))))

3926

                                                  (append (bind-bindings variables)

3927

                                                          (loop for binding in bindings

3928

                                                            for (var . value) = binding

3929

                                                            unless (loop for select-var in variables

3930

                                                                     when (or (eq select-var var) (and (consp select-var)

3931

                                                                                                       (eq (first select-var) var)))

3932

                                                                     return t)

3933

                                                            collect (list var value)))))

3934

,@args)))

3935

(t form))

3936

form)))

3937

(declare (dynamic-extent #'bind-form))

3938

(map-tree #'bind-form sse)))

3939

(:method (sse (bindings null))

3940

sse))

3941

 ;;; (bind-sparql-expression (parse-sparql "select ?x (abs(?y) as ?abs) where { ?s ?p1 ?x . ?s ?p2 ?y} group by ?s") '((?::|x| . 1) (?::|a| . 1)))

3942

3943

(defun cross-join-bindings (field1 field2 &optional slice)

3944

(destructuring-bind (solution-list1 dimensions1) (rest field1)

3945

(destructuring-bind (solution-list2 dimensions2) (rest field2)

3946

(if (intersection dimensions1 dimensions2) ;; not a cross-join

3947

`(spocq.e:join ,field1 ,field2 ,@(rest slice))

3948

(let ((solutions (loop for solution1 in solution-list1

3949

append (loop for solution2 in solution-list2

3950

                                       collect (append solution1 solution2)))))

3951

(when slice

3952

(destructuring-bind (&key (start 0) end) (rest slice)

3953

(setf solutions (subseq solutions start end))))

3954

`(spocq.a:|bindings| ,solutions ,(append dimensions1 dimensions2)))))))

3955

3956

(defgeneric add-sparql-bindings (bindings sse)

3957

(:documentation

3958

"rewrite a query sse form to intrduce the given bindings into a leaf.")

3959

(:method ((bindings cons) sse)

3960

(cond ((eq (first bindings) 'spocq.a:|bindings|) )

3961

((and (consp (first bindings)) (variable-p (caar bindings)))

3962

(setf bindings `(spocq.a:|bindings| (,(mapcar #'rest bindings))

3963

,(mapcar #'first bindings))))

3964

(t

3965

(error "invalid bindings: ~s" bindings)))

3966

(add-sparql-bindings-to-operator bindings (first sse) (rest sse)))

3967

(:method ((bindings null) sse)

3968

sse))

3969

3970

(defgeneric add-sparql-bindings-to-operator (bindings operator arguments)

3971

(:method (bindings (operator t) args)

3972

(error "form does not combine with bindings: ~s . ~s" operator args)))

3973

3974

(macrolet ((def-sparql-transform (operator lambda-list &body body)

3975

              `(defmethod add-sparql-bindings-to-operator (bindings (operator (eql ',operator)) parameters)

3976

(destructuring-bind ,lambda-list (cons bindings parameters)

3977

,@body))))

3978

3979

(def-sparql-transform spocq.a:|ask| (bindings field)

3980

`(spocq.a:|ask| ,(add-sparql-bindings bindings field)))

3981

3982

(def-sparql-transform spocq.a:|bgp| (bindings &rest triples)

3983

`(spocq.a:|join| ,bindings (spocq.a:|bgp| ,@triples)))

3984

3985

(def-sparql-transform spocq.a:|bindings| (bindings values variables)

3986

(cross-join-bindings bindings `(spocq.a:|bindings| ,values ,variables)))

3987

3988

(def-sparql-transform spocq.a:|construct| (bindings field triples)

3989

`(spocq.a:|construct| ,(add-sparql-bindings bindings field) ,triples))

3990

3991

(def-sparql-transform spocq.a:|describe| (bindings field subjects)

3992

`(spocq.a:|describe| ,(add-sparql-bindings bindings field) ,subjects))

3993

3994

(def-sparql-transform spocq.a:|diff| (bindings field1 field2 test-expression)

3995

`(spocq.a:|join| ,bindings (spocq.a:|diff| ,field1 ,field2 ,test-expression)))

3996

3997

(def-sparql-transform spocq.a:|distinct| (bindings field &rest args)

3998

`(spocq.a:|distinct| ,(add-sparql-bindings bindings field) ,@args))

3999

4000

(def-sparql-transform spocq.a:|extend| (bindings field variable value-expression)

4001

`(spocq.a:|extend| ,(add-sparql-bindings bindings field) ,variable ,value-expression))

4002

4003

(def-sparql-transform spocq.a:|filter| (bindings field test-expression)

4004

`(spocq.a:|filter| ,(add-sparql-bindings bindings field) ,test-expression))

4005

4006

(def-sparql-transform spocq.a:|graph| (bindings name group-graph-pattern)

4007

`(spocq.a:|join| ,bindings (spocq.a:|graph| ,name ,group-graph-pattern)))

4008

4009

(def-sparql-transform spocq.a:|join| (bindings field1 field2)

4010

`(spocq.a:|join| ,field1 ,(add-sparql-bindings bindings field2)))

4011

4012

(def-sparql-transform spocq.a:|leftjoin| (bindings field1 field2 &rest args)

4013

;; augment the base field

4014

`(spocq.a:|leftjoin| ,(add-sparql-bindings bindings field1) ,field2 ,@args))

4015

4016

(def-sparql-transform spocq.a:|minus| (bindings field1 field2)

4017

`(spocq.a:|join| ,bindings (spocq.a:|minus| ,field1 ,field2)))

4018

4019

(def-sparql-transform spocq.a:|null| (bindings dimensions)

4020

;; do not reduce immediately

4021

`(spocq.a:|join| ,bindings (spocq.a:|null| ,dimensions)))

4022

4023

(def-sparql-transform spocq.a:|order| (bindings field order-expression-list)

4024

`(spocq.a:|order| ,(add-sparql-bindings bindings field) ,order-expression-list))

4025

4026

(def-sparql-transform spocq.a:|project| (bindings field variables &rest args)

4027

`(spocq.a:|project| ,(add-sparql-bindings bindings field) ,variables ,@args))

4028

4029

(def-sparql-transform spocq.a:|reduced| (bindings field &rest args)

4030

`(spocq.a:|reduced| ,(add-sparql-bindings bindings field) ,@args))

4031

4032

(def-sparql-transform spocq.a:|select| (bindings field variables &rest args)

4033

`(spocq.a:|select| ,(add-sparql-bindings bindings field) ,variables ,@args))

4034

4035

(def-sparql-transform spocq.a:|service| (bindings name group-graph-pattern &rest args)

4036

`(spocq.a:|service| ,name ,(add-sparql-bindings bindings group-graph-pattern) ,@args))

4037

4038

(def-sparql-transform spocq.a:|slice| (bindings field &rest args)

4039

`(spocq.a:|slice| ,(add-sparql-bindings bindings field) ,@args))

4040

4041

(def-sparql-transform spocq.a:|table| (bindings &rest args)

4042

`(spocq.a:|join| ,bindings (spocq.a:|table| ,@args)))

4043

4044

(def-sparql-transform spocq.a:|union| (bindings field1 field2 test-expression)

4045

`(spocq.a:|join| ,bindings (spocq.a:|union| ,field1 ,field2 ,test-expression)))

4046

4047

)

4048

 ;;; (add-sparql-bindings '(spocq.a:|bindings| (?::a) ((1) (2))) (parse-sparql "select * where {?s ?p ?o}"))

4049

;;; (add-sparql-bindings '((?::a . 1) (?::b .2)) (parse-sparql "select * where {?s ?p ?o}"))

4050

4051

(defun walk-tree (function tree)

4052

"Walk the tree under the control of the mapped function.

4053

If it returns true, continue, otherwise return. Leaves the tree unmodified."

4054

4055

(declare (dynamic-extent function))

4056

4057

(flet ((map-element (e) (walk-tree function e)))

4058

(declare (dynamic-extent #'map-element))

4059

(when (funcall function tree)

4060

(typecase tree

4061

(cons (walk-tree function (first tree))

4062

(walk-tree function (rest tree)))

4063

(vector (map nil #'map-element tree))))))

4064

4065

4066

(defun merge-property-lists (&rest lists)

4067

(flet ((do-merge (l1 l2)

4068

(loop for (property value) on l2 by #'cddr

4069

when (eq (getf l1 property lists) lists)

4070

do (progn (push value l1)

4071

(push property l1)))

4072

l1))

4073

(reduce #'do-merge lists)))

4074

;; (merge-property-lists '(:a 1 :b 2) '(:b 3 :c 3) '(:d 4 :a 4))

4075

4076

(:documentation "blank nodes and variables in patterns and data"

4077

"quad/triple patterns appear in three interpretation contexts:

4078

- graph/bgp matching patterns

4079

these may have constants, blank nodes, and variables - both

4080

distinguished and non. the match binds distinguished variables

4081

but neither non-distinguished nor blank nodes.

4082

- graph-triple patterns specified insertion or deletion in

4083

combination with bindings from a where clause

4084

in both contexts, these may have distinguished variables to

4085

accept the bindings from the where clause.

4086

for deletion, neither blank nodes no non-distinguished variables

4087

are permitted, as bindings are required.

4088

for insertion blank nodes and non-distinguished variables are

4089

permitted and are mapped to new nodes per pattern invocation.

4090

- graph/triple data specified in-line for insertion or deletion

4091

in both contexts, these may _not_ have distinguished variables.

4092

for deletion, they may not have blank nodes or non-distinguished

4093

variables while for insertion, blank nodes are mapped to new nodes

4094

per pattern invocation.

4095

4096

the constraints are applied in the delete/insert/update operators

4097

and the logic to generate new blank nodes is in the code which

4098

computes modify operators and that which interns fields.

4099

4100

cf. http://www.w3.org/TR/sparql11-query/#sparqlGrammar

4101

4102

8. The QuadData and QuadPattern rules both use rule Quads. The rule QuadData,

4103

used in INSERT DATA and DELETE DATA, must not allow variables in the quad

4104

patterns.

4105

9. Blank node syntax is not allowed in DELETE WHERE, the DeleteClause for

4106

DELETE, nor in DELETE DATA.")

4107

4108

4109

(defun validate-quad-data (data mode)

4110

"Require that the data comprise constants or new blank node indicators only.

4111

if anything else is present, signal an error."

4112

(flet ((insertion-term-p (term)

4113

(not (distinguished-variable-p term)))

4114

(deletion-term-p (term)

4115

(not (or (variable-p term)

4116

(spocq:blank-node-p term)))))

4117

(let ((term-predicate (ecase mode

4118

(:insert #'insertion-term-p)

4119

(:delete #'deletion-term-p))))

4120

(labels ((validate-data (data)

4121

(typecase data

4122

(null )

4123

(cons (case (first data)

4124

(spocq.a:|list|

4125

(map nil #'validate-data (rest data)))

4126

(spocq.a:|graph|

4127

(destructuring-bind (iri . statements) (rest data)

4128

(assert (iri-p iri) ()

4129

                                       "Graph designator must be an iri: ~s." iri)

4130

(map nil #'validate-data statements)))

4131

((spocq.a:|triple| spocq.a:|quad|)

4132

(unless (every term-predicate (statement-terms data))

4133

                               (spocq.e:request-error "Statement terms may not be variables: ~a." data)))

4134

(t

4135

(if (consp (first data))

4136

(loop for datum in data

4137

do (validate-data datum))

4138

(error "Invalid quad data: ~s." data)))))

4139

(t

4140

(error "Invalid quad data: ~s." data)))))

4141

(validate-data data)))))

4142

4143

4144

(defun validate-quad-pattern (pattern mode)

4145

"Require that, for deletion, the pattern may not include nondistinguished variables or

4146

blank node indicators.

4147

if anything else is present, signal an error."

4148

(flet ((deletion-term-p (term)

4149

(not (or (undistinguished-variable-p term)

4150

(spocq:blank-node-p term)))))

4151

(let ((term-predicate (ecase mode

4152

(:insert #'identity)

4153

(:delete #'deletion-term-p))))

4154

(labels ((validate-pattern (pattern)

4155

(typecase pattern

4156

(null )

4157

(cons (case (first pattern)

4158

(spocq.a:|list|

4159

(map nil #'validate-pattern (rest pattern)))

4160

(spocq.a:|graph|

4161

                             (destructuring-bind (var-or-iri . statements) (rest pattern)

4162

                               (assert (or (iri-p var-or-iri) (variable-p var-or-iri)) ()

4163

                                       "Graph designator must be a variable or an iri: ~s." var-or-iri)

4164

(map nil #'validate-pattern statements)))

4165

((spocq.a:|triple| spocq.a:|quad|)

4166

(unless (every term-predicate (statement-terms pattern))

4167

                               (spocq.e:request-error "Statement terms must be constant or variable: ~a." pattern)))

4168

(t

4169

(if (consp (first pattern))

4170

(loop for datum in pattern

4171

do (validate-pattern datum))

4172

(error "Invalid quad pattern: ~s." pattern)))))

4173

(t

4174

(error "Invalid quad pattern: ~s." pattern)))))

4175

(validate-pattern pattern)))))

4176

4177

4178

(defun symbol-uri-namestring (symbol)

4179

"retrieve namestring, create if not present"

4180

(de.setf.resource.implementation::symbol-uri-namestring symbol))

4181

4182

(defun (setf symbol-uri-namestring) (uri-namestring symbol)

4183

(setf (de.setf.resource.implementation::symbol-uri-namestring symbol) uri-namestring))

4184

4185

4186

(defun get-symbol-uri-namestring (symbol)

4187

"retrieve, but do not create, the namestring.

4188

should be present for iri only."

4189

(get symbol :namestring))

4190

4191

(defun symbol-term-id (symbol)

4192

(get symbol 'symbol-term-id))

4193

4194

(defun (setf symbol-term-id) (id symbol)

4195

(setf (get symbol 'symbol-term-id) id))

4196

4197

(defun symbol-string-id (symbol)

4198

"return the string dictionary id for the string which is the

4199

lexical form of the respective type name"

4200

(get symbol 'symbol-string-id))

4201

4202

(defun (setf symbol-string-id) (id symbol)

4203

(setf (get symbol 'symbol-string-id) id))

4204

4205

(defvar *foreign-string-addresses* (make-hash-table :test 'eql))

4206

4207

(defun datatype-foreign-string (datatype-symbol)

4208

(or (get datatype-symbol 'foreign-string)

4209

(error "No foreign string present: ~s." datatype-symbol)))

4210

4211

(defun (setf datatype-foreign-string) (pointer datatype-symbol)

4212

(setf (gethash (cffi:pointer-address pointer) *foreign-string-addresses*) datatype-symbol)

4213

(setf (get datatype-symbol 'foreign-string) pointer))

4214

4215

(defun contingently-foreign-free (string-pointer)

4216

(when string-pointer

4217

(cond ((cffi:null-pointer-p string-pointer) nil)

4218

((gethash (cffi:pointer-address string-pointer) *foreign-string-addresses*) nil)

4219

(t (cffi:foreign-free string-pointer) t))))

4220

4221

(defgeneric initialize-store (repository-class store-uri store-library)

4222

(:method ((repository-type symbol) store-uri store-library)

4223

(initialize-store (find-class repository-type) store-uri store-library))

4224

(:method ((repository-class class) store-uri store-library)

4225

(c2mop:ensure-finalized repository-class)

4226

(initialize-store (allocate-instance repository-class) store-uri store-library)))

4227

4228

(defgeneric reinitialize-store (repository-class)

4229

(:method ((repository-type symbol))

4230

(reinitialize-store (find-class repository-type)))

4231

(:method ((repository-class class))

4232

(c2mop:ensure-finalized repository-class)

4233

(reinitialize-store (allocate-instance repository-class)))

4234

(:method ((repository t))

4235

t))

4236

4237

4238

(defun initialize-uri-symbols ()

4239

(clrhash *foreign-string-addresses*)

4240

(dolist (package *iri-packages* t) (initialize-package-uri-symbols package)))

4241

4242

(defgeneric initialize-package-uri-symbols (package)

4243

(:method ((package package))

4244

(flet ((initialize-symbol (symbol lexical-form)

4245

(let ((foreign-string (cffi:foreign-string-alloc lexical-form)))

4246

(export symbol (symbol-package symbol))

4247

(setf (datatype-foreign-string symbol) foreign-string)

4248

(cond ((boundp symbol)

4249

(unless (eq (symbol-value symbol) symbol)

4250

                         (log-warn "Invalid uri symbol binding: ~s -> ~s." symbol (symbol-value symbol))))

4251

(t

4252

(eval `(defconstant ,symbol ',symbol)))))))

4253

(let ((package-symbol (intern "" package)))

4254

(initialize-symbol package-symbol (package-name package)))

4255

(with-package-iterator (get-next-symbol package :external :internal)

4256

(loop (multiple-value-bind (next-p symbol) (get-next-symbol)

4257

(unless next-p (return))

4258

;; ensure namestring is present

4259

                 (initialize-symbol symbol (de.setf.resource.implementation::symbol-uri-namestring symbol))))))

4260

t)

4261

(:method ((designator string))

4262

(initialize-package-uri-symbols (find-package designator))))

4263

4264

(describe 'spocq.a:|describe|)

4265

(initialize-uri-symbols)

4266

(describe 'spocq.a:|describe|)

4267

4268

(defparameter *true-all-context-term-number* nil)

4269

(defparameter *true-default-context-term-number* nil)

4270

(defparameter *true-named-context-term-number* nil)

4271

(defparameter *true-none-context-term-number* nil)

4272

(defparameter *none-context-term-number* -4)

4273

4274

(defun initialize-interned-terms ()

4275

"Reset the lexical->spocq registry and the rdfcache<->spocq term registries.

4276

  For each vocabulary term (uri) register all three equivalences between the symbol and its term number,

4277

and cache its lexical form and foreign string."

4278

4279

(clrhash *lexical->spocq-term-registry*)

4280

(clrhash *spocq->store-term-registry*)

4281

(clrhash *store->spocq-term-registry*)

4282

(initialize-uri-symbols)

4283

(let ((count 0)

4284

(failures ()))

4285

(cffi:with-foreign-objects ((%term '(:struct rdfcache::term)))

4286

(rdfcache::%clear-term %term)

4287

(labels ((bind-term-number (symbol term-number)

4288

(setf (gethash term-number *store->spocq-term-registry*) symbol

4289

(gethash symbol *spocq->store-term-registry*) term-number

4290

(symbol-term-id symbol) term-number))

4291

(register-term (symbol lexical-form)

4292

                  (setf (gethash (list :uri lexical-form) *lexical->spocq-term-registry*) symbol)

4293

(incf count)

4294

(cffi:with-foreign-string (%lexical-form lexical-form)

4295

                    (rdfcache:initialize-term %term :uri %lexical-form :language nil :datatype nil)

4296

(let ((id (rdfcache::lookup-term-number %term)))

4297

(cond (id

4298

(bind-term-number symbol id))

4299

(t

4300

(log-warn "Interning missing term <~a>." lexical-form)

4301

(bind-term-number symbol

4302

(rdfcache:intern-term nil

4303

                                                                     (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::type)

4304

                                                                     (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::value)

4305

                                                                     (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::language)

4306

                                                                     (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::datatype)))))))))

4307

4308

(dolist (package *iri-packages*)

4309

(let ((package-symbol (intern "" package)))

4310

(register-term package-symbol (package-name package)))

4311

(with-package-iterator (get-next-symbol package :external :internal)

4312

(loop (multiple-value-bind (next-p symbol) (get-next-symbol)

4313

(unless next-p (return))

4314

(let ((namestring (symbol-uri-namestring symbol)))

4315

(register-term symbol namestring)

4316

                       (setf (symbol-string-id symbol) (rlmdb::string-dictionary-get namestring)))))))))

4317

(when failures

4318

(log-error "Terms not present in the store: ~a."

4319

(with-output-to-string (stream)

4320

(dolist (failure failures)

4321

(write-char #\space stream)

4322

(encode-turtle-object failure stream))))

4323

(cerror "Continue without them."

4324

"Cannot locate ~d/~d terms in the store." (length failures) count))

4325

(flet ((reregister-term (symbol id)

4326

(unless (eql (symbol-term-id symbol) id)

4327

(log-info "reregister: ~s: ~s." symbol id)

4328

;; leave the original id -> symbol map entry

4329

(setf (gethash id *store->spocq-term-registry*) symbol

4330

(gethash symbol *spocq->store-term-registry*) id

4331

(symbol-term-id symbol) id))))

4332

(unless *true-all-context-term-number*

4333

(setf *true-all-context-term-number* (symbol-term-id '|urn:dydra|:|all|)))

4334

(reregister-term '|urn:dydra|:|all| rdfcache:*all-context-number*)

4335

(unless *true-default-context-term-number*

4336

(setf *true-default-context-term-number* (symbol-term-id '|urn:dydra|:|default|)))

4337

(reregister-term '|urn:dydra|:|default| rdfcache:*default-context-number*)

4338

(unless *true-named-context-term-number*

4339

(setf *true-named-context-term-number* (symbol-term-id '|urn:dydra|:|named|)))

4340

(reregister-term '|urn:dydra|:|named| rdfcache:*named-context-number*)

4341

(unless *true-none-context-term-number*

4342

(setf *true-none-context-term-number* (symbol-term-id '|urn:dydra|:|none|)))

4343

(reregister-term '|urn:dydra|:|none| *none-context-term-number*))

4344

count))

4345

;;; (initialize-interned-terms)

4346

4347

4348

;; (gethash '(:uri "http://www.w3.org/2001/XMLSchema#yearMonthDuration") *lexical->spocq-term-registry*)

4349

4350

#+(or) ;; did not handle rdf:_1 &co

4351

(defun construct-prefixed-name (item)

4352

(let* ((colon-position (or (position #\: item) (error "invalid pname_ld syntax: ~s." item)))

4353

(pn_prefix (subseq item 0 colon-position))

4354

(pn_local (subseq item (1+ colon-position)))

4355

(namespace-uri (prefix-namespace pn_prefix))

4356

;; need to cache these

4357

(namespace-namestring (term-lexical-form namespace-uri)))

4358

(if (member namespace-namestring *iri-package-names* :test #'string-equal)

4359

(or (find-symbol pn_local namespace-namestring)

4360

(when *strict-vocabulary-terms*

4361

(error "Invalid vocabulary resource: ~s." item))

4362

(merge-and-intern-iri (concatenate 'string namespace-namestring pn_local)))

4363

(merge-and-intern-iri (concatenate 'string namespace-namestring pn_local)))))

4364

4365

(defun construct-prefixed-name (item)

4366

(let* ((colon-position (or (position #\: item) (error "invalid pname_ld syntax: ~s." item)))

4367

(pn_prefix (subseq item 0 colon-position))

4368

(pn_local (subseq item (1+ colon-position)))

4369

(namespace-uri (prefix-namespace pn_prefix))

4370

;; need to cache these

4371

(namespace-namestring (term-lexical-form namespace-uri)))

4372

     ;; the un-escape from pn_local bnf must be performed here as the item here is itself a terminal

4373

(setf pn_local (remove #\\ pn_local))

4374

(intern-iri (concatenate 'string namespace-namestring pn_local))))

4375

4376

4377

(defparameter *uri-unreserved-characters*

4378

"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz-_.~")

4379

(defparameter *uri-unreserved-bytes*

4380

(map 'vector #'char-code *uri-unreserved-characters*))

4381

4382

(defun encode-for-uri (string)

4383

"Return the string with any reserved characters replaced by a string of characters which

4384

encode the 'corresponding percent-encoded US-ASCII octet', as specified by RFC 3986. This

4385

implements the XQuery function [fn:encode-for-uri](http://www.w3.org/TR/xpath-functions/#func-encode-for-uri)

4386

for use in SPARQL's encode_fo_uri operator."

4387

(if (position-if #'(lambda (c) (not (find c *uri-unreserved-characters*))) string)

4388

(let* ((utf8-bytes (encode-string string :utf-8))

4389

(utf8-end (length utf8-bytes))

4390

            (result (make-string (+ utf8-end (* 2 (count-if #'(lambda (b) (not (find b *uri-unreserved-bytes*)))

4391

                                                            utf8-bytes)))))

4392

(result-position 0))

4393

(loop for byte across utf8-bytes

4394

if (position byte *uri-unreserved-bytes*)

4395

do (setf (aref result result-position) (code-char byte)

4396

result-position (1+ result-position))

4397

else do (multiple-value-bind (high low) (truncate byte 16)

4398

(setf (aref result result-position) #\%)

4399

                       (setf (aref result (incf result-position)) (aref *uri-unreserved-characters* high))

4400

                       (setf (aref result (incf result-position)) (aref *uri-unreserved-characters* low))

4401

(incf result-position)))

4402

result)

4403

(copy-seq string)))

4404

4405

;;; cache literal expression for round-tripping

4406

4407

(defun literal-string (value)

4408

"For literals which have internal representations, return the external representation

4409

if one was present."

4410

(gethash value *literal-strings*))

4411

4412

(defun (setf literal-string) (string value)

4413

"For literals which have internal representations, return the external representation

4414

if one was present."

4415

(setf (gethash value *literal-strings*) string))

4416

4417

4418

(defgeneric construct-iri (lexical-form)

4419

(:method ((lexical-form string))

4420

(construct-term :uri lexical-form nil nil))

4421

(:method ((iri spocq:iri))

4422

iri)

4423

(:method ((iri uuid:uuid))

4424

(construct-iri (prin1-to-string iri)))

4425

(:method ((uri puri:uri))

4426

(construct-iri (with-output-to-string (stream) (puri:render-uri uri stream)))))

4427

4428

(defgeneric intern-iri-normalized (lexical-form)

4429

(:method ((lexical-form string))

4430

(when (char= #\< (char lexical-form 0)) ;; coerce <...> forms

4431

(assert (char= #\> (char lexical-form (1- (length lexical-form)))))

4432

(setf lexical-form (subseq lexical-form 1 (1- (length lexical-form)))))

4433

(intern-iri lexical-form))

4434

(:method ((iri t))

4435

(intern-iri iri)))

4436

4437

(defgeneric intern-iri (lexical-form)

4438

(:method ((lexical-form string))

4439

(intern-term-aspects :uri lexical-form nil nil))

4440

(:method ((iri spocq:iri))

4441

"Given an iri instance, reintern it to ensure identity in the given context."

4442

(intern-term-aspects :uri (spocq:iri-lexical-form iri) nil nil))

4443

(:method ((uuid uuid:uuid))

4444

(intern-uuid uuid))

4445

(:method ((uri puri:uri))

4446

(intern-iri (with-output-to-string (stream) (puri:render-uri uri stream))))

4447

(:method ((iri null))

4448

;; allow null -> null

4449

iri)

4450

(:method ((iri symbol))

4451

(assert (get-symbol-uri-namestring iri) () "Invalid symbol iri: ~s." iri)

4452

iri)

4453

(:method ((object t))

4454

(error "Invalid iri form: ~s." object)))

4455

4456

(defun (setf intern-iri) (value lexical-form)

4457

(setf (gethash (list :uri lexical-form) *lexical->spocq-term-registry*) value))

4458

4459

(defgeneric ensure-iri (object)

4460

(:method ((iri spocq:iri)) iri)

4461

(:method ((object null)) (error "Invalid iri form: ~s." object))

4462

(:method ((object t)) (intern-iri object)))

4463

4464

(defgeneric iri-equal (iri1 iri2)

4465

(:method ((iri1 symbol) (iri2 symbol))

4466

(eq iri1 iri2))

4467

(:method ((iri1 t) (iri2 t))

4468

(or (eql iri1 iri2)

4469

(string-equal (iri-lexical-form iri1) (iri-lexical-form iri2)))))

4470

4471

(defgeneric intern-sub-iri (base extension)

4472

(:method ((base string) (extension string))

4473

(intern-iri (concatenate 'string base extension)))

4474

(:method ((base spocq:iri) (extension string))

4475

(intern-sub-iri (spocq:iri-lexical-form base) extension)))

4476

4477

4478

(defgeneric intern-uuid (object)

4479

(:method ((lexical-form string))

4480

(intern-iri (cond ((string-equal "urn:uuid:" lexical-form :end2 (min (length lexical-form) 9))

4481

lexical-form)

4482

                       ((string-equal "uuid:" lexical-form :end2 (min (length lexical-form) 5))

4483

(concatenate 'string "urn:" lexical-form))

4484

(t

4485

(concatenate 'string "urn:uuid:" lexical-form)))))

4486

(:method ((uuid uuid:uuid))

4487

(intern-iri (prin1-to-string uuid))))

4488

4489

(progn

4490

(cffi:define-foreign-library libuuid

4491

(:unix (:or "libuuid.so.1" "libuuid.so"))

4492

(t (:default "libuuid")))

4493

(CFFI:LOAD-FOREIGN-LIBRARY 'libuuid)

4494

(cffi:defcfun ("uuid_generate_time" %uuid-generate-time) :pointer (uuid :pointer))

4495

(cffi:defcfun ("uuid_generate_random" %uuid-generate-random) :pointer (uuid :pointer))

4496

(cffi:defcfun ("uuid_time" %uuid-time) :uint64 (uuid :pointer) (timeval :pointer))

4497

(cffi:defcstruct timeval

4498

(tv_sec :uint64)

4499

(tv_usec :uint64))

4500

(cffi:defcstruct v1-uuid

4501

(time_low :uint32)

4502

(time_mid :uint16)

4503

(time_hi_and_version :uint16)

4504

(clock_seq :uint16)

4505

(node_high :uint16)

4506

(node_low :uint32))

4507

4508

(defun make-uuid-vector ()

4509

(make-array +uuid-length+ :element-type '(unsigned-byte 8)))

4510

(defun uuid-vector-p (object)

4511

(typep object '(array (unsigned-byte 8) (16))))

4512

(deftype uuid-vector () '(satisfies uuid-vector-p))

4513

4514

(defparameter *uuid-timeout* 1)

4515

4516

(defun %uuid-to-string (%uuid &optional (uuid (make-string 36 :initial-element #\-) uuid-s))

4517

(let ((hex "0123456789ABCDEF"))

4518

(labels ((transcribe-byte (%uuid uuid from to)

4519

(let ((byte (cffi:mem-aref %uuid :uint8 from)))

4520

(setf (char uuid to) (char hex (ash byte -4))

4521

(char uuid (1+ to)) (char hex (logand byte #x0f)))))

4522

(transcribe-segment (%uuid uuid from to count)

4523

(loop for i below count

4524

for from from from

4525

for to from to by 2

4526

do (transcribe-byte %uuid uuid from to)))

4527

(transcribe-uuid (%uuid uuid)

4528

(transcribe-segment %uuid uuid 0 0 4)

4529

(transcribe-segment %uuid uuid 4 9 2)

4530

(transcribe-segment %uuid uuid 6 14 2)

4531

(transcribe-segment %uuid uuid 8 19 2)

4532

(transcribe-segment %uuid uuid 10 24 6)))

4533

(when uuid-s

4534

(loop for to in '(8 13 18 23) do (setf (char uuid to) #\-)))

4535

(transcribe-uuid %uuid uuid)

4536

uuid)))

4537

4538

(defun make-v1-uuid-string (&optional (uuid (make-string 36 :initial-element #\-)))

4539

(bt:with-timeout (*uuid-timeout*)

4540

(cffi:with-foreign-objects ((%uuid '(:struct v1-uuid)))

4541

(%uuid-generate-time %uuid)

4542

(%uuid-to-string %uuid uuid))))

4543

4544

(defun make-v1-uuid-array (&optional (vector (make-array 16 :element-type '(unsigned-byte 8))))

4545

(bt:with-timeout (*uuid-timeout*)

4546

(cffi:with-foreign-objects ((%uuid '(:struct v1-uuid)))

4547

(%uuid-generate-time %uuid)

4548

(loop for i below 16

4549

do (setf (aref vector i) (cffi:mem-aref %uuid :uint8 i)))

4550

vector)))

4551

4552

(defun make-v4-uuid-string (&optional (uuid (make-string 36 :initial-element #\-)))

4553

(cffi:with-foreign-objects ((%uuid '(:struct v1-uuid)))

4554

(%uuid-generate-random %uuid)

4555

(%uuid-to-string %uuid uuid)))

4556

4557

(defgeneric uuid-timestamp (uuid)

4558

(:method ((uuid uuid:uuid))

4559

(uuid-timestamp (uuid:uuid-to-byte-array uuid)))

4560

(:method ((uuid vector))

4561

(rdfcache::with-uuid (%uuid)

4562

(loop for i below 16

4563

do (setf (cffi:mem-aref %uuid :uint8 i) (aref uuid i)))

4564

(cffi:with-foreign-object (%timeval '(:struct timeval))

4565

(%uuid-time %uuid %timeval)

4566

(+ (* 1000000 (cffi:foreign-slot-value %timeval '(:struct timeval) 'tv_sec))

4567

(cffi:foreign-slot-value %timeval '(:struct timeval) 'tv_usec)))))

4568

(:method ((uuid string))

4569

(uuid-timestamp (string-to-uuid uuid (make-uuid-vector)))))

4570

(defmethod uuid-to-string ((uuid vector))

4571

(with-output-to-string (stream) (cl-user::format-uuid stream uuid)))

4572

(defmethod cl-user::format-uuid (stream uuid &optional colon at)

4573

(declare (ignore colon at))

4574

(flet ((output-bytes (offset count)

4575

(loop for i below count for index from offset

4576

do (format stream "~(~2,'0x~)" (aref uuid index)))))

4577

(output-bytes 0 4)

4578

(write-char #\- stream)

4579

(output-bytes 4 2)

4580

(write-char #\- stream)

4581

(output-bytes 6 2)

4582

(write-char #\- stream)

4583

(output-bytes 8 2)

4584

(write-char #\- stream)

4585

(output-bytes 10 6 )))

4586

(defmethod string-to-uuid (string (uuid vector))

4587

(setf string (uuid-string string))

4588

(loop with from = 0

4589

with to = 0

4590

until (>= to (length uuid))

4591

do (if (char= (char string from) #\-)

4592

(incf from)

4593

(setf (aref uuid (shiftf to (1+ to)))

4594

(parse-integer string :start from :end (incf from 2) :radix 16))))

4595

uuid)

4596

(defun string-to-uuid-vector (string)

4597

(string-to-uuid string (make-uuid-vector)))

4598

(defgeneric %encode-uuid (uuid %uuid)

4599

(:documentation "encode any of various uuid forms into a 16-byte foreign array")

4600

(:method ((uuid string) (%uuid SB-SYS:SYSTEM-AREA-POINTER))

4601

(%encode-uuid (string-to-uuid uuid (make-uuid-vector)) %uuid))

4602

(:method ((uuid vector) (%uuid SB-SYS:SYSTEM-AREA-POINTER))

4603

(loop for i below 16

4604

do (setf (cffi:mem-aref %uuid :uint8 i) (aref uuid i)))

4605

%uuid))

4606

(defun %decode-uuid (%uuid uuid)

4607

(loop for i below 16

4608

do (setf (aref uuid i) (cffi:mem-aref %uuid :uint8 i)))

4609

uuid))

4610

 ;;; (let ((v (make-v1-uuid-array))) (equalp v (string-to-uuid (uuid-to-string v) (make-array 16 :element-type '(unsigned-byte 8)))))

4611

4612

4613

(defun cons-uuid-symbol ()

4614

(make-symbol (make-v1-uuid-string)))

4615

;; (cons-uuid-symbol)

4616

4617

(defun cons-v1-uuid ()

4618

(spocq:make-uuid (concatenate 'string "urn:uuid:" (make-v1-uuid-string))))

4619

4620

(defgeneric uuid-string (object)

4621

(:method ((uuid string))

4622

(cond ((string-equal "urn:" uuid :end2 4)

4623

(subseq uuid 9))

4624

((string-equal "uuid:" uuid :end2 5)

4625

(subseq uuid 5))

4626

(t

4627

uuid)))

4628

(:method ((uuid spocq:uuid))

4629

(subseq (spocq:uuid-lexical-form uuid) 9)))

4630

4631

(defgeneric v1-uuid-timestamp (uuid)

4632

(:method ((uuid string))

4633

(v1-uuid-timestamp (string-to-uuid uuid (make-uuid-vector))))

4634

(:method ((uuid vector))

4635

;; (v1-uuid-timestamp (uuid:byte-array-to-uuid uuid))

4636

(let ((timestamp 0))

4637

(setf (ldb (byte 32 0) timestamp) (de.setf.utility.codecs:buffer-get-unsigned-byte-32 uuid 0))

4638

(setf (ldb (byte 16 32) timestamp) (de.setf.utility.codecs:buffer-get-unsigned-byte-16 uuid 4))

4639

       (setf (ldb (byte 12 48) timestamp) (ldb (byte 12 0) (de.setf.utility.codecs:buffer-get-unsigned-byte-16 uuid 6)))

4640

timestamp)

4641

)

4642

(:method ((uuid uuid:uuid))

4643

(let ((timestamp 0))

4644

(setf (ldb (byte 32 0) timestamp) (uuid::time-low uuid))

4645

(setf (ldb (byte 16 32) timestamp) (uuid::time-mid uuid))

4646

(setf (ldb (byte 12 48) timestamp) (ldb (byte 12 0) (uuid::time-high uuid)))

4647

timestamp)))

4648

#|

4649

(let ((uuid (make-array 16 :element-type '(unsigned-byte 8)

4650

                         :initial-contents '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))))

4651

(time (dotimes (x 1000000)

4652

(v1-uuid-timestamp uuid))))

4653

;;; buffer-get : 0.171/0bytes

4654

;;; uuid:uuid : 0.853/80Mbytes

4655

|#

4656

4657

(defgeneric (setf v1-uuid-timestamp) (timestamp uuid)

4658

(:method (timestamp (uuid vector))

4659

(flet ((set-high (value) (de.setf.utility.codecs:buffer-set-unsigned-byte-16 uuid value 6))

4660

(set-mid (value) (de.setf.utility.codecs:buffer-set-unsigned-byte-16 uuid value 4))

4661

(set-low (value) (de.setf.utility.codecs:buffer-set-unsigned-byte-32 uuid value 0)))

4662

(set-high (ldb (byte 12 48) timestamp))

4663

(set-mid (ldb (byte 16 32) timestamp))

4664

(set-low (ldb (byte 32 0) timestamp)))

4665

#+(or)

4666

(let ((uuid:uuid (uuid:byte-array-to-uuid uuid)))

4667

(setf (v1-uuid-timestamp uuid:uuid) timestamp)

4668

(replace uuid (uuid:uuid-to-byte-array uuid:uuid) :end1 10))

4669

timestamp)

4670

(:method (timestamp (uuid uuid:uuid))

4671

(setf (uuid::time-low uuid) (ldb (byte 32 0) timestamp))

4672

(setf (uuid::time-mid uuid) (ldb (byte 16 32) timestamp))

4673

(setf (uuid::time-high uuid) (ldb (byte 12 48) timestamp))

4674

timestamp))

4675

4676

(defgeneric uuid-node (uuid)

4677

(:method ((uuid string))

4678

(uuid-node (string-to-uuid uuid (make-uuid-vector))))

4679

(:method ((uuid uuid:uuid))

4680

(uuid::node uuid))

4681

(:method ((uuid spocq:uuid))

4682

(uuid-node (string-to-uuid (spocq:uuid-lexical-form uuid) (make-uuid-vector))))

4683

(:method ((uuid vector))

4684

(de.setf.utility.codecs::buffer-get-unsigned-byte-48 uuid 10)))

4685

4686

(defgeneric (setf uuid-node) (node uuid)

4687

;; does not permit changes to a uuid term

4688

(:method (node (uuid uuid:uuid))

4689

(setf (uuid::node uuid) node))

4690

(:method (node (uuid vector))

4691

(de.setf.utility.codecs::buffer-set-unsigned-byte-48 uuid node 10)))

4692

4693

;;; no media types

4694

(defgeneric intern-sha256-urn (object)

4695

(:method ((lexical-form string))

4696

(intern-iri (cond ((string-equal "urn:hash:" lexical-form :end2 (min (length lexical-form) 9))

4697

lexical-form)

4698

                       ((string-equal "hash:" lexical-form :end2 (min (length lexical-form) 5))

4699

(concatenate 'string "urn:" lexical-form))

4700

(t

4701

(concatenate 'string "urn:hash::sha256:" lexical-form))))))

4702

(defgeneric sha256-urn-hash (object)

4703

(:method ((object spocq:sha256-urn))

4704

(subseq (spocq:sha256-urn-lexical-form object) (load-time-value (length "urn:hash::sha256:"))))

4705

(:method ((object string))

4706

(ecase (length object)

4707

       (#.(+ (length "urn:hash::sha256:") (/ 256 4)) (subseq object (load-time-value (length "urn:hash::sha256:"))))

4708

(64 object))))

4709

4710

4711

(defgeneric intern-file-url (object)

4712

(:method ((pathname pathname))

4713

(intern-file-url (namestring pathname)))

4714

(:method ((pathname string))

4715

(intern-iri (cond ((string-equal "file:" pathname :end2 (min (length pathname) 5))

4716

;; it need not have a host

4717

pathname)

4718

(t

4719

(concatenate 'string "file://" pathname))))))

4720

4721

(defgeneric file-url-pathname (object)

4722

(:method ((url spocq:file-url))

4723

(multiple-value-bind (host path)

4724

(parse-file-url-host-and-path (spocq:iri-lexical-form url))

4725

(declare (ignore host))

4726

(assert (stringp path) ()

4727

"Invalid file url: ~s" url)

4728

(pathname path))))

4729

;;; (file-url-pathname (intern-file-url #p"/tmp/test"))

4730

;;; (file-url-pathname (intern-file-url #p"tmp/test"))

4731

4732

(defgeneric merge-and-intern-iri (iri-namestring &key base-iri)

4733

(:method ((iri t) &rest args)

4734

(declare (dynamic-extent args))

4735

(apply #'merge-and-intern-iri (iri-lexical-form iri) args))

4736

(:method ((iri-namestring string) &key (base-iri (base-iri)))

4737

;; base iri should always have a value

4738

(when (and base-iri (not (position #\: iri-namestring)))

4739

(let* ((puri::*parse-uri-string* #'puri::parse-iri-string)

4740

(puri::*escape-uri-string* nil) ; do not escape when parsing the components

4741

(puri (puri:merge-uris iri-namestring (iri-lexical-form base-iri))))

4742

(setf iri-namestring (with-output-to-string (stream) (puri:render-uri puri stream)))))

4743

(intern-term-aspects :uri iri-namestring nil nil)))

4744

4745

(defun intern-blank-node (label)

4746

(intern-term-aspects :node label nil nil))

4747

4748

(defun intern-literal (lexical-form datatype)

4749

(intern-term-aspects :literal lexical-form datatype nil))

4750

4751

(defun intern-plain-literal (lexical-form language-tag)

4752

(intern-term-aspects :literal lexical-form nil (string language-tag)))

4753

4754

4755

(defun intern-term-aspects (term-type lexical-form datatype language-tag)

4756

(let ((key (list* term-type lexical-form (or datatype language-tag))))

4757

(declare (dynamic-extent key))

4758

(or (gethash key *lexical->spocq-term-registry*)

4759

(setf (gethash (copy-list key) *lexical->spocq-term-registry*)

4760

(construct-term term-type lexical-form datatype language-tag)))))

4761

4762

4763

(defun unintern-term-aspects (term-type lexical-form datatype language-tag)

4764

(let ((key (list* term-type lexical-form (or datatype language-tag))))

4765

(declare (dynamic-extent key))

4766

(remhash key *lexical->spocq-term-registry*)))

4767

4768

(defun intern-term-aspects-copy (term-type lexical-form datatype language-tag)

4769

(let ((key (list* term-type lexical-form (or datatype language-tag))))

4770

(declare (dynamic-extent key))

4771

(or (gethash key *lexical->spocq-term-registry*)

4772

(let ((new-key (list* term-type (copy-seq lexical-form)

4773

(cond (datatype (copy-seq datatype))

4774

(language-tag (copy-seq language-tag))))))

4775

(setf (gethash new-key *lexical->spocq-term-registry*)

4776

(construct-term term-type lexical-form datatype language-tag))))))

4777

4778

4779

(defvar *site-genid-uri-prefix* )

4780

4781

(defvar *site-genid-uri-prefix-length* )

4782

4783

(defun site-genid-uri-prefix ()

4784

(the string (if (boundp '*site-genid-uri-prefix*)

4785

*site-genid-uri-prefix*

4786

(setq *site-genid-uri-prefix*

4787

                         (concatenate 'string "http://" (site-name) "/.well-known/genid/")))))

4788

4789

(defun site-genid-uri-prefix-length ()

4790

(the (integer 0) (if (boundp '*site-genid-uri-prefix-length*)

4791

*site-genid-uri-prefix-length*

4792

                        (setq *site-genid-uri-prefix-length* (length (site-genid-uri-prefix))))))

4793

4794

(defun find-vocabulary-package (iri-lexical-form)

4795

(let ((iri-lexical-form-length (length iri-lexical-form)))

4796

(flet ((test-vocabulary-uri (base-uri)

4797

(let ((base-length (length base-uri)))

4798

(cond ((<= base-length iri-lexical-form-length)

4799

;; allow exact match

4800

(string-equal iri-lexical-form base-uri :end1 base-length))

4801

((and (= base-length (1+ iri-lexical-form-length))

4802

                              (string-equal iri-lexical-form base-uri :end1 (1- base-length)))

4803

(case (char base-uri iri-lexical-form-length)

4804

((#\/ #\#) t)))))))

4805

(declare (dynamic-extent #'test-vocabulary-uri))

4806

(find-if #'test-vocabulary-uri *iri-package-names*))))

4807

4808

(defun vocabulary-identifier (context lexical-form)

4809

(let ((base-iri (etypecase context (string context) (package (package-name context))))

4810

(package (etypecase context (string (find-package context)) (package context))))

4811

(when package

4812

(let* ((package-length (length base-iri))

4813

(lexical-length (length lexical-form)))

4814

(cond ((<= package-length lexical-length)

4815

(let ((local-part (subseq lexical-form package-length))

4816

(separator nil))

4817

(when (plusp (length local-part))

4818

(setf separator (char local-part 0))

4819

(case separator

4820

((#\/ #\# #\:) (setf local-part (subseq local-part 1)))))

4821

(let ((symbol (find-symbol local-part package)))

4822

(setf (get symbol 'separator) separator)

4823

symbol)))

4824

((= package-length (1+ lexical-length))

4825

(let ((separator (char base-iri lexical-length)))

4826

(when (case separator

4827

((#\/ #\# #\:) t))

4828

(let ((symbol (find-symbol "" package)))

4829

(setf (get symbol 'separator) separator)

4830

symbol)))))))))

4831

4832

(defparameter *uri-scheme-scanner*

4833

(cl-ppcre:create-scanner `(:sequence :start-anchor

4834

(:register (:alternation "file"

4835

                                                                 "http" "https"

4836

                                                                 "mailto"

4837

                                                                 "mqtt" "mqtts" ;; construction in server;extensions;mqtt.lisp

4838

                                                                 "mysql"

4839

                                                                 "odbc" ;; construction in odbc-uri.lisp

4840

                                                                 "postgresql" ;; same

4841

                                                                 ;; must call them out rather then allowing '[^:]*'

4842

                                                                 "urn:uuid" "urn" "uuid"

4843

                                                                 "ws" "wss"))

4844

":")))

4845

4846

(defun parse-uri-scheme (lexical-form)

4847

(multiple-value-bind (whole strings) (cl-ppcre:scan-to-strings *uri-scheme-scanner* lexical-form)

4848

(when whole

4849

(intern (string-upcase (aref strings 0)) :keyword))))

4850

4851

(defparameter *url-authority-scanner*

4852

(cl-ppcre:create-scanner `(:sequence :start-anchor

4853

(:alternation "http" "https")

4854

"://"

4855

(:register

4856

                                         (:greedy-repetition 0 nil (:inverted-char-class #\/)))

4857

                                        (:GREEDY-REPETITION 0 NIL :EVERYTHING)

4858

:end-anchor)))

4859

;;; ietf odbc uri scheme

4860

;;; odbc:[driver]//[user]:[password]@[host]:[port]/[database]/[tables]?[query]

4861

;;; simplified to

4862

;;; odbc://host/database/table

4863

4864

(defparameter *file-url-scanner*

4865

(cl-ppcre:create-scanner `(:sequence :start-anchor

4866

"file:"

4867

(:greedy-repetition 0 1

4868

(:sequence "//"

4869

(:register

4870

                                                     (:greedy-repetition 0 nil

4871

                                                      (:inverted-char-class #\/)))))

4872

(:register

4873

                                         (:sequence (:greedy-repetition 0 1 #\/)

4874

                                                    (:GREEDY-REPETITION 0 NIL :EVERYTHING))))))

4875

;;; (parse-file-url-host-and-path "file://asdf.qwer")

4876

;;; (parse-file-url-host-and-path "file://asdf.qwer/path/path")

4877

;;; (parse-file-url-host-and-path "file:///path/path")

4878

;;; (parse-file-url-host-and-path "file:/path/path")

4879

;;; (parse-file-url-host-and-path "file:path/path")

4880

4881

(defparameter *url-authority+path-scanner*

4882

(cl-ppcre:create-scanner `(:sequence :start-anchor

4883

                                        (:register (:greedy-repetition 0 1 (:alternation "http" "https")))

4884

"://"

4885

                                        (:register (:greedy-repetition 0 nil (:inverted-char-class #\/)))

4886

(:greedy-repetition 0 1

4887

                                                            (:sequence

4888

                                                             (:greedy-repetition 0 1

4889

                                                                                 (:sequence

4890

#\/

4891

                                                                                  (:register

4892

                                                                                   (:sequence (:greedy-repetition 1 nil (:inverted-char-class #\/ #\? #\& #\# #\{))

4893

                                                                                              (:greedy-repetition 0 1

4894

                                                                                                                  (:sequence #\/

4895

                                                                                                                             (:greedy-repetition 0 nil (:inverted-char-class #\/ #\? #\& #\# #\{))))))))

4896

                                                             (:greedy-repetition 0 1

4897

                                                                                 (:sequence #\/

4898

                                                                                            (:register

4899

                                                                                             (:greedy-repetition 1 nil (:inverted-char-class #\/ #\? #\& #\# #\{)))))

4900

                                                             (:sequence

4901

                                                              (:greedy-repetition 0 1 #\/)

4902

                                                              (:register (:GREEDY-REPETITION 0 NIL :EVERYTHING)))))

4903

:end-anchor)))

4904

(defparameter *url-query-scanner*

4905

(cl-ppcre:create-scanner `(:sequence :start-anchor

4906

(:alternation "http" "https")

4907

"://"

4908

                                        (:greedy-repetition 0 nil (:inverted-char-class #\?))

4909

(:greedy-repetition 0 1

4910

                                                            (:sequence #\?

4911

                                                                       (:register

4912

                                                                        (:greedy-repetition 0 nil (:inverted-char-class #\#)))))

4913

                                        (:GREEDY-REPETITION 0 NIL :EVERYTHING)

4914

:end-anchor)))

4915

(defparameter *repository-id-scanner*

4916

(cl-ppcre:create-scanner `(:sequence :start-anchor

4917

                                        (:register (:greedy-repetition 1 nil (:alternation :word-char-class #\- #\_ #\.)))

4918

#\/

4919

                                        (:register (:greedy-repetition 1 nil  (:alternation :word-char-class #\- #\_ #\.)))

4920

(:greedy-repetition 0 1

4921

                                                            (:sequence (:char-class #\? #\/) (:register (:GREEDY-REPETITION 0 NIL :EVERYTHING))))

4922

4923

:end-anchor)))

4924

4925

(defparameter *view-repository-id-scanner*

4926

(cl-ppcre:create-scanner `(:sequence :start-anchor

4927

                                        (:register (:greedy-repetition 1 nil (:alternation :word-char-class #\- #\_ #\.)))

4928

#\/

4929

                                        (:register (:greedy-repetition 1 nil (:alternation :word-char-class #\- #\_ #\.)))

4930

"__"

4931

                                        (:register (:greedy-repetition 1 nil (:alternation :word-char-class #\- #\_ #\.)))

4932

"__view"

4933

:end-anchor))

4934

"regex scanner for materialized view repositories")

4935

4936

(defparameter *view-identifier-scanner*

4937

(cl-ppcre:create-scanner `(:sequence :start-anchor

4938

(:greedy-repetition 0 1 (:sequence

4939

                                                                 (:greedy-repetition 0 1 (:sequence

4940

                                                                                          (:alternation "http" "https")

4941

                                                                                          "://"

4942

                                                                                          (:greedy-repetition 1 nil (:inverted-char-class #\/))))

4943

                                                                 #\/))

4944

                                        (:register (:greedy-repetition 1 nil (:inverted-char-class #\/)))

4945

#\/

4946

                                        (:register (:greedy-repetition 1 nil (:inverted-char-class #\/)))

4947

#\/

4948

                                        (:register (:greedy-repetition 1 nil (:inverted-char-class #\.)))

4949

                                        (:greedy-repetition 0 1 (:sequence #\. (:register (:GREEDY-REPETITION 0 NIL :EVERYTHING))))

4950

:end-anchor))

4951

"regex scanner for view identifiers")

4952

4953

(macrolet ((def-regex-parser (name (parameter &optional (required t)) &rest args)

4954

(let ((documentation (when (stringp (first args)) (pop args)))

4955

(scanner (pop args)))

4956

`(defgeneric ,name (,parameter &key junk-allowed)

4957

,@(when documentation `((:documentation ,documentation)))

4958

(:method ((,parameter string) &key (junk-allowed ,(not required)))

4959

                     (multiple-value-bind (parse registers) (cl-ppcre:scan-to-strings ,scanner ,parameter)

4960

(cond (parse

4961

,@args

4962

                              (apply #'values (loop for element across registers collect (when (plusp (length element)) element))))

4963

(junk-allowed

4964

nil)

4965

(t

4966

                              (error ,(format nil "~a: invalid value: ~~s" name) ,parameter)))))

4967

(:method ((,parameter spocq:iri) &rest args)

4968

(declare (dynamic-extent args))

4969

(apply #',name (spocq:iri-lexical-form ,parameter) args))

4970

(:method ((,parameter puri:uri) &rest args)

4971

(declare (dynamic-extent args))

4972

(apply #',name (iri-lexical-form ,parameter) args))

4973

(:method ((,parameter t) &key (junk-allowed ,(not required)))

4974

(unless junk-allowed

4975

(error ,(format nil "~a: invalid value: ~~s" name) ,parameter))

4976

nil)))))

4977

(def-regex-parser parse-url-authority (iri)

4978

"Return the url authority field"

4979

*url-authority-scanner*)

4980

;; (parse-url-authority "http://example.org")

4981

;; (parse-url-authority "http://example.org/")

4982

;; (parse-url-authority "http://example.org/asdf#qwer")

4983

4984

(def-regex-parser parse-file-url-host-and-path (iri)

4985

"Return the file url host and path"

4986

*file-url-scanner*)

4987

;; (parse-file-url-host-and-path "file://asdf.qwer")

4988

(def-regex-parser parse-url-authority+path (iri nil)

4989

"Return as five values: protocol, authority, path, view, args"

4990

*url-authority+path-scanner*

4991

)

4992

;; (parse-url-authority+path "http://fragments.dbpedia.org/{?subject,predicate,object}#x")

4993

;; (parse-url-authority+path "http://fragments.dbpedia.org/account/resource{?subject,predicate,object}#x")

4994

;; (parse-url-authority+path "http://fragments.dbpedia.org/account/resource/{?subject,predicate,object}#x")

4995

   ;; (parse-url-authority+path "http://fragments.dbpedia.org/account/resource/view.csv{?subject,predicate,object}#x")

4996

   ;; (parse-url-authority+path "http://fragments.dbpedia.org/account/resource/view.csv/{?subject,predicate,object}#x")

4997

;; (parse-url-authority+path "http://fragments.dbpedia.org/account/resource/view.csv")

4998

;; (parse-url-authority+path "http://fragments.dbpedia.org/account/resource/extra/view.csv")

4999

;; (parse-url-authority+path "account/resource/view.csv") -> nil

5000

;; (parse-url-authority+path "template/cloudsearch2Did.csv?cloudsearchtype=StripID") -> nil

5001

;; (parse-url-authority+path <http://dbpedia.org/sparql>)

5002

;; (parse-url-authority+path <http://dbpedia.org/sparql/>)

5003

(def-regex-parser parse-url-query-string (iri)

5004

"Return the url quest string, if present"

5005

*url-query-scanner*)

5006

;; (parse-url-query-string "http://fragments.dbpedia.org/?revision=1234&user_id=2#x")

5007

;; (parse-url-query-string "http://fragments.dbpedia.org/#x")

5008

(def-regex-parser parse-repository-id (iri)

5009

"Return the url quest string, if present"

5010

*repository-id-scanner*)

5011

;; (parse-repository-id "account-1/resource")

5012

;; (parse-repository-id "account-1/resource/extra")

5013

(def-regex-parser parse-view-repository-id (namestring nil)

5014

"Return the components of a materialized view repository id"

5015

*view-repository-id-scanner*)

5016

;; (parse-view-repository-id "account-1/repo__some-view-name__view")

5017

(def-regex-parser parse-view-identifier (namestring nil)

5018

"Return the components of a view identifier"

5019

*view-identifier-scanner*)

5020

;; (parse-view-identifier "http://dydra.com/account-1/repo-2") -> nil

5021

;; (parse-view-identifier "http://dydra.com/account-1/repo-2/some-view-name")

5022

;; (parse-view-identifier "/account-1/repo-2/some-view-name")

5023

;; (parse-view-identifier "account-1/repo-2/some-view-name")

5024

;; (parse-view-identifier "/repo-2/some-view-name") -> nil

5025

;; (parse-view-identifier "http://dydra.com/account-1/repo-2/some-view-name.rq")

5026

)

5027

5028

(defun is-http-url (object)

5029

(is-http-url-namestring object))

5030

5031

(defun is-http-url-namestring (object)

5032

(and (stringp object)

5033

(cl-ppcre:scan *url-authority-scanner* object)))

5034

5035

(defun is-file-url-namestring (object)

5036

(and (stringp object)

5037

(not (null (parse-file-url-host-and-path object)))))

5038

5039

(defun is-local-host (authority)

5040

(or (member authority (list "localhost" "127.0.0.1" (host-name) (site-name))

5041

:test #'string-equal)

5042

(member authority *localhost-authorities*

5043

:test #'string-equal)))

5044

5045

(defgeneric iri-service-repository-id (location)

5046

(:method ((location null))

5047

nil)

5048

(:method ((location symbol))

5049

(let ((namestring (get-symbol-uri-namestring location)))

5050

(when namestring (iri-service-repository-id namestring))))

5051

(:method ((location spocq:iri))

5052

(iri-service-repository-id (url-decode (spocq:iri-lexical-form location))))

5053

5054

(:method ((parsed-iri puri:uri))

5055

(iri-service-repository-id (iri-lexical-form parsed-iri)))

5056

5057

(:method ((location string))

5058

(multiple-value-bind (protocol authority path)

5059

(parse-url-authority+path location :junk-allowed t)

5060

(declare (ignore protocol))

5061

(cond ((and (or (null authority) (is-local-host authority))

5062

path)

5063

;; if local, return the local repository id and the parsed iri

5064

(multiple-value-bind (account repository) ;; check the syntax

5065

(parse-repository-id path :junk-allowed t)

5066

(when account

5067

(values (make-repository-id :account-name account :repository-name repository)

5068

location))))

5069

(authority

5070

nil)

5071

(t

5072

(multiple-value-bind (account repository) ;; check the syntax

5073

(parse-repository-id location :junk-allowed t)

5074

(when account

5075

(values (make-repository-id :account-name account :repository-name repository)

5076

location))))))))

5077

;;; (iri-service-repository-id "http://localhost/asdf/qwer/view?rev=HEAD")

5078

;;; (iri-service-repository-id "http://localhost/asdf/qwer/view")

5079

;;; (iri-service-repository-id "http://localhost/asdf/qwer?rev=HEAD")

5080

;;; (iri-service-repository-id "http://localhost/asdf/qwer")

5081

;;; (iri-service-repository-id "asdf/qwer?rev=HEAD")

5082

;;; (iri-service-repository-id "asdf/qwer/view")

5083

5084

(defgeneric service-repository-revision (location)

5085

(:method ((location string))

5086

(let* ((location-query-parameters (parse-query-parameters (parse-url-query-string location)))

5087

(revision-id (or (getf location-query-parameters :revision-id)

5088

(getf location-query-parameters :revision)

5089

(getf location-query-parameters :revision-uuid))))

5090

revision-id))

5091

(:method ((location spocq:iri))

5092

(service-repository-revision (url-decode (spocq:iri-lexical-form location)))))

5093

5094

5095

 ;;; (loop for uri in '("http:example" "urn:xxx" "urn:uuid:1234" "file:///example" "urnx") collect (parse-uri-scheme uri))

5096

5097

5098

(defun constrain-string-length (string)

5099

"constrain the string to be of a length less than any configured limit."

5100

(cond ((and *rdf-string-length-maximum*

5101

(> (length string) *rdf-string-length-maximum*))

5102

(log-error "string ~s exceeds length limit of ~s"

5103

(type-of string) *rdf-string-length-maximum*)

5104

(error "string ~s exceeds length limit of ~s"

5105

(type-of string) *rdf-string-length-maximum*))

5106

(t

5107

string)))

5108

5109

(defgeneric construct-term (term-type lexical-form datatype language-tag)

5110

(:documentation "Construct a term object for the given type x lexical for x (datatype + tag)"))

5111

5112

(defmethod construct-term ((term-type (eql :uri)) lexical-form datatype language-tag)

5113

(when (or language-tag datatype)

5114

(warn "Improper attribute combination for an iri: ~s ~s ~s ~s."

5115

term-type lexical-form language-tag datatype))

5116

(construct-uri-term (parse-uri-scheme lexical-form) lexical-form))

5117

5118

(defgeneric construct-uri-term (scheme lexical-form)

5119

(:documentation "Given the uril scheme parse and/or construct an uri of the respective type.")

5120

(:method ((scheme t) lexical-form)

5121

(flet ((as-blank-node-constant (lexical-form)

5122

              "construct an uninterned constant blank node given either the literal blank node prefix

5123

               or the standard genid uri prefix. we recognize them, but do not generate them.

5124

see http://www.w3.org/TR/rdf11-concepts/#section-skolemization"

5125

(cond ((string-equal "_:" lexical-form :end2 (min (length lexical-form) 2))

5126

(let ((node (spocq:make-blank-node (subseq lexical-form 2))))

5127

;; construct a new node and mark it as constant

5128

(setf (spocq:blank-node-constant-p node) t)

5129

node))

5130

((string-equal (site-genid-uri-prefix) lexical-form

5131

                                   :end2 (min (length lexical-form) (site-genid-uri-prefix-length)))

5132

                     (let ((node (spocq:make-blank-node (subseq lexical-form (site-genid-uri-prefix-length)))))

5133

;; construct a new node and mark it as constant

5134

(setf (spocq:blank-node-constant-p node) t)

5135

node)))))

5136

(cond ((as-blank-node-constant lexical-form))

5137

((is-uuid-string lexical-form)

5138

(spocq:make-uuid (concatenate 'string "urn:uuid:" lexical-form)))

5139

(t

5140

(spocq:make-iri lexical-form))))))

5141

5142

(defmethod construct-uri-term ((scheme (eql :|URN:UUID|)) lexical-form)

5143

(assert (is-uuid-string lexical-form :start 9) ()

5144

"Invalid uuid: ~s" lexical-form)

5145

(spocq:make-uuid lexical-form))

5146

5147

(defmethod construct-uri-term ((scheme (eql :UUID)) lexical-form)

5148

(assert (is-uuid-string lexical-form :start 5) ()

5149

"Invalid uuid: ~s" lexical-form)

5150

(spocq:make-uuid (concatenate 'string "urn:" lexical-form)))

5151

5152

(defmethod construct-uri-term ((scheme (eql :mailto)) lexical-form)

5153

(spocq:make-mailto-url lexical-form))

5154

5155

(defmethod construct-uri-term ((scheme (eql :file)) lexical-form)

5156

(spocq:make-file-url lexical-form))

5157

5158

(defmethod construct-uri-term ((scheme (eql :urn)) lexical-form)

5159

(let* ((length (length lexical-form)))

5160

(if (and (= length (load-time-value (+ (length "urn:hash::sha256:") (/ 256 4))))

5161

              (string= "urn:hash::sha256:" lexical-form :end2 (load-time-value (length "urn:hash::sha256:"))))

5162

(spocq:make-sha256-urn lexical-form)

5163

(let ((vocabulary-package (find-vocabulary-package lexical-form)))

5164

           ;; if it is part of a vocabulary which is modeled as a package, intern it as a symbol

5165

;; do not create automatically, as to constrain membership except for list nodes,

5166

;; for which a non-symbol represents the term

5167

(if vocabulary-package

5168

               (or ;; (de.setf.resource.implementation::uri-namestring-identifier lexical-form #'string nil)

5169

(vocabulary-identifier vocabulary-package lexical-form)

5170

;; this after vocabularies

5171

(spocq:make-iri lexical-form))

5172

(spocq:make-iri lexical-form))))))

5173

5174

5175

(defmethod construct-uri-term ((scheme (eql :https)) lexical-form)

5176

(construct-uri-term :http lexical-form))

5177

5178

(defmethod construct-uri-term ((scheme (eql :http)) lexical-form)

5179

(let ((vocabulary-package (find-vocabulary-package lexical-form)))

5180

(cond (vocabulary-package

5181

            ;; if it is part of a vocabulary which is modeled as a package, intern it as a symbol

5182

;; do not create automatically, as to constrain membership except for list nodes,

5183

;; for which a non-symbol represents the term

5184

            (or ;; (de.setf.resource.implementation::uri-namestring-identifier lexical-form #'string nil)

5185

(vocabulary-identifier vocabulary-package lexical-form)

5186

;; this after vocabularies

5187

             (let* ((rdf-length (load-time-value (length "http://www.w3.org/1999/02/22-rdf-syntax-ns#")))

5188

(spin-length (load-time-value (length "http://spinrdf.org/sp#")))

5189

(create (or (not *strict-vocabulary-terms*)

5190

(and (> (length lexical-form) (1+ rdf-length))

5191

(eql (char lexical-form rdf-length) #\_)

5192

                                     (string-equal lexical-form "http://www.w3.org/1999/02/22-rdf-syntax-ns#" :end1 rdf-length)

5193

                                     (not (find-if (complement #'digit-char-p) lexical-form :start (1+ rdf-length))))

5194

(and (> (length lexical-form) (+ spin-length 3))

5195

                                     (string-equal lexical-form "http://spinrdf.org/sp#arg" :end1 (+ spin-length 3))

5196

                                     (not (find-if (complement #'digit-char-p) lexical-form :start (+ spin-length 3)))))))

5197

(if create

5198

                   (cond ((or (string-equal "http:" lexical-form :end2 (min (length lexical-form) 5))

5199

                              (string-equal "https:" lexical-form :end2 (min (length lexical-form) 6)))

5200

(spocq:make-http-url lexical-form))

5201

(t

5202

(spocq:make-iri lexical-form)))

5203

(spocq.e::vocabulary-error :expression lexical-form)))))

5204

(t

5205

(spocq:make-http-url lexical-form)))))

5206

5207

(defmethod construct-term ((term-type (eql :none)) lexical-form datatype language-tag)

5208

(when (or lexical-form language-tag datatype)

5209

(warn "Improper attribute combination for a null: ~s ~s ~s ~s."

5210

term-type lexical-form language-tag datatype))

5211

spocq.a:|unbound|)

5212

5213

(defmethod construct-term ((term-type (eql :node)) lexical-form datatype language-tag)

5214

(when (or language-tag datatype)

5215

(warn "Improper attribute combination for a blank node: ~s ~s ~s ~s."

5216

term-type lexical-form language-tag datatype))

5217

(spocq:make-blank-node lexical-form))

5218

5219

(defmethod construct-term ((term-type (eql :literal)) lexical-form (datatype string) (language-tag null))

5220

(construct-term :literal lexical-form (intern-iri datatype) language-tag))

5221

5222

(defmethod construct-term ((term-type (eql :literal)) lexical-form (datatype t) (language-tag t))

5223

(warn "Improper attribute combination for a literal: ~s ~s ~s ~s."

5224

term-type lexical-form datatype language-tag)

5225

lexical-form)

5226

5227

(defmethod construct-term ((term-type (eql :literal)) lexical-form (datatype null) (language-tag null))

5228

lexical-form)

5229

5230

(defmethod construct-term ((term-type (eql :literal)) lexical-form (datatype null) (language-tag t))

5231

(construct-term :literal lexical-form nil (string language-tag)))

5232

5233

(defmethod construct-term ((term-type (eql :literal)) lexical-form (datatype null) (language-tag string))

5234

(spocq:make-plain-literal lexical-form language-tag))

5235

5236

 (defmethod construct-term ((term-type (eql :literal)) lexical-form (datatype (eql |rdf|:|langString|)) (language-tag string))

5237

(spocq:make-plain-literal lexical-form language-tag))

5238

5239

(defmethod construct-term ((term-type (eql :literal)) lexical-form (datatype symbol) (language-tag null))

5240

(flet ((parse-date-time (lexical-form)

5241

(case (length lexical-form)

5242

#+(or) (20 (|-yyyy-MM-ddTHH:mm:ssZZZZ| (concatenate 'string lexical-form "00")))

5243

#+(or) (t (|-yyyy-MM-ddTHH:mm:ssZZZZ| lexical-form "00")))))

5244

(handler-case (case datatype

5245

(|xsd|:|boolean| (spocq.e:boolean lexical-form))

5246

                       ;; must check lexical conformance (|xsd|:|dateTime| (spocq:make-date-time :lexical-form lexical-form)

5247

(|xsd|:|dateTime| (|-yyyy-MM-ddTHH:mm:ss(ZZZZZZ)?| lexical-form))

5248

                       ;; must check lexical conformance (|xsd|:|date| (spocq:make-date :lexical-form lexical-form)

5249

(|xsd|:|date| (|-yyyy-MM-dd(ZZZZ)?| lexical-form))

5250

(|xsd|:|duration|

5251

(|PnYnMnDTnHnMnS| lexical-form))

5252

(|xsd|:|decimal| (spocq.e:decimal lexical-form))

5253

(|xsd|:|double| (spocq.e:double lexical-form))

5254

(|xsd|:|float| (spocq.e:float lexical-form))

5255

(|xsd|:|integer| (spocq.e:integer lexical-form))

5256

(|xsd|:|string| lexical-form)

5257

5258

(|xsd|:|dayTimeDuration| (|PnDTnHnMnS| lexical-form))

5259

(|xsd|:|gDay| (|---dd(ZZZZZZ)?| lexical-form))

5260

(|xsd|:|gMonth| (|--MM(ZZZZZZ)?| lexical-form))

5261

(|xsd|:|gMonthDay| (|--MM-dd(ZZZZZZ)?| lexical-form))

5262

(|xsd|:|gYear| (|YYYY(ZZZZZZ)?| lexical-form))

5263

(|xsd|:|gYearMonth| (|YYYY-MM(ZZZZZZ)?| lexical-form))

5264

(|xsd|:|time|

5265

                        ;; must check lexical conformance (spocq:make-time :lexical-form lexical-form))

5266

(|HH:mm:ss(ZZZZ)?| lexical-form))

5267

(|xsd|:|yearMonthDuration| (|PnYnM| lexical-form))

5268

;; intervals

5269

(|time|:|DateInterval| (|time|:|dateInterval| lexical-form))

5270

(|time|:|DateTimeInterval| (|time|:|dateTimeInterval| lexical-form))

5271

(|time|:|TimeInterval| (|time|:|timeInterval| lexical-form))

5272

(t

5273

                        (if (let ((class (find-class datatype nil))) (and class (subtypep class '|xsd|:|integer|)))

5274

(spocq.e:integer lexical-form)

5275

(spocq:make-unsupported-typed-literal lexical-form datatype))))

5276

(condition (condition)

5277

(spocq:make-unsupported-typed-literal lexical-form datatype condition)))))

5278

5279

   (defmethod construct-term ((term-type (eql :literal)) lexical-form (datatype spocq:iri) (language-tag null))

5280

     "Iff the type is an iri object rather than a symbol, then the type is not a known native type"

5281

(spocq:make-unsupported-typed-literal lexical-form datatype))

5282

5283

#+(or)

5284

(defgeneric construct-term (term-type lexical-form datatype language-tag)

5285

(:method ((term-type (eql :uri)) lexical-form datatype language-tag)

5286

(when (or language-tag datatype)

5287

(warn "Improper attribute combination for an iri: ~s ~s ~s ~s."

5288

term-type lexical-form language-tag datatype))

5289

(let ((vocabulary-package nil))

5290

(flet ((as-blank-node-constant (lexical-form)

5291

                "construct an uninterned constant blank node given either the literal blank node prefix

5292

                 or the standard genid uri prefix. we recognize them, but do not generate them.

5293

see http://www.w3.org/TR/rdf11-concepts/#section-skolemization"

5294

(cond ((string-equal "_:" lexical-form :end2 (min (length lexical-form) 2))

5295

(let ((node (spocq:make-blank-node (subseq lexical-form 2))))

5296

;; construct a new node and mark it as constant

5297

(setf (spocq:blank-node-constant-p node) t)

5298

node))

5299

((string-equal (site-genid-uri-prefix) lexical-form

5300

                                     :end2 (min (length lexical-form) (site-genid-uri-prefix-length)))

5301

                       (let ((node (spocq:make-blank-node (subseq lexical-form (site-genid-uri-prefix-length)))))

5302

;; construct a new node and mark it as constant

5303

(setf (spocq:blank-node-constant-p node) t)

5304

node)))))

5305

(cond ((string-equal "urn:uuid:" lexical-form :end2 (min (length lexical-form) 9))

5306

(assert (is-uuid-string lexical-form :start 9) ()

5307

"Invalid uuid: ~s" lexical-form)

5308

(spocq:make-uuid lexical-form))

5309

((string-equal "mailto:" lexical-form :end2 (min (length lexical-form) 7))

5310

(spocq:make-mailto-url lexical-form))

5311

((as-blank-node-constant lexical-form))

5312

((setf vocabulary-package (find-vocabulary-package lexical-form))

5313

                ;; if it is part of a vocabulary which is modeled as a package, intern it as a symbol

5314

                ;; do not create automatically, as to constrain membership except for list nodes,

5315

;; for which a non-symbol represents the term

5316

                (or ;; (de.setf.resource.implementation::uri-namestring-identifier lexical-form #'string nil)

5317

(vocabulary-identifier vocabulary-package lexical-form)

5318

;; this after vocabularies

5319

(when (string-equal "urn:" lexical-form :end2 (min (length lexical-form) 4))

5320

(spocq:make-iri lexical-form))

5321

                 (let* ((rdf-length (load-time-value (length "http://www.w3.org/1999/02/22-rdf-syntax-ns#")))

5322

(spin-length (load-time-value (length "http://spinrdf.org/sp#")))

5323

(create (or (not *strict-vocabulary-terms*)

5324

                                    (and (> (length lexical-form) (1+ rdf-length))

5325

                                         (eql (char lexical-form rdf-length) #\_)

5326

                                         (string-equal lexical-form "http://www.w3.org/1999/02/22-rdf-syntax-ns#" :end1 rdf-length)

5327

                                         (not (find-if (complement #'digit-char-p) lexical-form :start (1+ rdf-length))))

5328

                                    (and (> (length lexical-form) (+ spin-length 3))

5329

                                         (string-equal lexical-form "http://spinrdf.org/sp#arg" :end1 (+ spin-length 3))

5330

                                         (not (find-if (complement #'digit-char-p) lexical-form :start (+ spin-length 3)))))))

5331

(if create

5332

                       (cond ((or (string-equal "http:" lexical-form :end2 (min (length lexical-form) 5))

5333

                                  (string-equal "https:" lexical-form :end2 (min (length lexical-form) 6)))

5334

(spocq:make-http-url lexical-form))

5335

(t

5336

(spocq:make-iri lexical-form)))

5337

(spocq.e::vocabulary-error :expression lexical-form)))))

5338

((or (string-equal "http:" lexical-form :end2 (min (length lexical-form) 5))

5339

(string-equal "https:" lexical-form :end2 (min (length lexical-form) 6)))

5340

(spocq:make-http-url lexical-form))

5341

((string-equal "file:" lexical-form :end2 (min (length lexical-form) 5))

5342

(spocq:make-file-url lexical-form))

5343

(t

5344

(spocq:make-iri lexical-form))))))

5345

5346

(:method ((term-type (eql :none)) lexical-form datatype language-tag)

5347

(when (or lexical-form language-tag datatype)

5348

(warn "Improper attribute combination for a null: ~s ~s ~s ~s."

5349

term-type lexical-form language-tag datatype))

5350

spocq.a:|unbound|)

5351

5352

(:method ((term-type (eql :node)) lexical-form datatype language-tag)

5353

(when (or language-tag datatype)

5354

(warn "Improper attribute combination for a blank node: ~s ~s ~s ~s."

5355

term-type lexical-form language-tag datatype))

5356

(spocq:make-blank-node lexical-form))

5357

5358

(:method ((term-type (eql :literal)) lexical-form (datatype string) (language-tag null))

5359

(construct-term :literal lexical-form (intern-iri datatype) language-tag))

5360

5361

(:method ((term-type (eql :literal)) lexical-form (datatype t) (language-tag t))

5362

(warn "Improper attribute combination for a literal: ~s ~s ~s ~s."

5363

term-type lexical-form datatype language-tag)

5364

lexical-form)

5365

5366

(:method ((term-type (eql :literal)) lexical-form (datatype null) (language-tag null))

5367

lexical-form)

5368

5369

(:method ((term-type (eql :literal)) lexical-form (datatype null) (language-tag t))

5370

(construct-term :literal lexical-form nil (string language-tag)))

5371

5372

(:method ((term-type (eql :literal)) lexical-form (datatype null) (language-tag string))

5373

(spocq:make-plain-literal lexical-form language-tag))

5374

5375

(:method ((term-type (eql :literal)) lexical-form (datatype symbol) (language-tag null))

5376

(flet ((parse-date-time (lexical-form)

5377

(case (length lexical-form)

5378

#+(or) (20 (|-yyyy-MM-ddTHH:mm:ssZZZZ| (concatenate 'string lexical-form "00")))

5379

#+(or) (t (|-yyyy-MM-ddTHH:mm:ssZZZZ| lexical-form "00")))))

5380

(handler-case (case datatype

5381

(|xsd|:|boolean| (spocq.e:boolean lexical-form))

5382

                       ;; must check lexical conformance (|xsd|:|dateTime| (spocq:make-date-time :lexical-form lexical-form)

5383

(|xsd|:|dateTime| (|-yyyy-MM-ddTHH:mm:ss(ZZZZZZ)?| lexical-form))

5384

                       ;; must check lexical conformance (|xsd|:|date| (spocq:make-date :lexical-form lexical-form)

5385

(|xsd|:|date| (|-yyyy-MM-dd(ZZZZ)?| lexical-form))

5386

(|xsd|:|duration|

5387

(|PnYnMnDTnHnMnS| lexical-form))

5388

(|xsd|:|decimal| (spocq.e:decimal lexical-form))

5389

(|xsd|:|double| (spocq.e:double lexical-form))

5390

(|xsd|:|float| (spocq.e:float lexical-form))

5391

(|xsd|:|integer| (spocq.e:integer lexical-form))

5392

(|xsd|:|string| lexical-form)

5393

5394

(|xsd|:|dayTimeDuration| (|PnDTnHnMnS| lexical-form))

5395

(|xsd|:|gDay| (|---dd(ZZZZZZ)?| lexical-form))

5396

(|xsd|:|gMonth| (|--MM(ZZZZZZ)?| lexical-form))

5397

(|xsd|:|gMonthDay| (|--MM-dd(ZZZZZZ)?| lexical-form))

5398

(|xsd|:|gYear| (|YYYY(ZZZZZZ)?| lexical-form))

5399

(|xsd|:|gYearMonth| (|YYYY-MM(ZZZZZZ)?| lexical-form))

5400

(|xsd|:|time|

5401

                        ;; must check lexical conformance (spocq:make-time :lexical-form lexical-form))

5402

(|HH:mm:ss(ZZZZ)?| lexical-form))

5403

(|xsd|:|yearMonthDuration| (|PnYnM| lexical-form))

5404

;; intervals

5405

(|time|:|DateInterval| (|time|:|dateInterval| lexical-form))

5406

(|time|:|DateTimeInterval| (|time|:|dateTimeInterval| lexical-form))

5407

(|time|:|TimeInterval| (|time|:|timeInterval| lexical-form))

5408

(t

5409

                        (if (let ((class (find-class datatype nil))) (and class (subtypep class '|xsd|:|integer|)))

5410

(spocq.e:integer lexical-form)

5411

(spocq:make-unsupported-typed-literal lexical-form datatype))))

5412

(condition (condition)

5413

(spocq:make-unsupported-typed-literal lexical-form datatype condition)))))

5414

5415

(:method ((term-type (eql :literal)) lexical-form (datatype spocq:iri) (language-tag null))

5416

(spocq:make-unsupported-typed-literal lexical-form datatype)))

5417

5418

#+(or)

5419

(defun parse-decimal2 (string)

5420

(let* ((dot (position #\. string))

5421

(slash (position #\/ string))

5422

(minusp (eql (char string 0) #\-))

5423

(plusp (eql (char string 0) #\+))

5424

(start (if (or plusp minusp) 1 0)))

5425

(cond (dot

5426

(let* ((whole (parse-integer string :end dot :start start))

5427

(fraction-digits (- (length string) (1+ dot)))

5428

(fraction-value (if (plusp fraction-digits)

5429

(parse-integer string :start (1+ dot))

5430

0))

5431

(factor (if (plusp fraction-digits) (expt 10 fraction-digits) 1))

5432

(value (/ (+ (* factor whole) fraction-value) factor)))

5433

(if minusp (- value) value)))

5434

(slash

5435

(let* ((numerator (parse-integer string :end slash :start start))

5436

(denominator (parse-integer string :start (1+ slash)))

5437

(value (/ numerator denominator)))

5438

(if minusp (- value) value)))

5439

(t

5440

(let ((value (parse-integer string :start start)))

5441

(if minusp (- value) value))))))

5442

5443

(defun read-buffer (stream predicate)

5444

(let ((buffer (make-array 8 :element-type 'character :fill-pointer 0 :adjustable t)))

5445

(loop (let ((char (read-char stream)))

5446

(unless (funcall predicate char)

5447

(unread-char char stream)

5448

(return (copy-seq buffer)))

5449

(vector-push-extend char buffer)))))

5450

5451

(defparameter *property-path-bounds-readtable* (copy-readtable nil))

5452

 (set-macro-character #\{ #'(lambda (stream c) (declare (ignore c)) (read-delimited-list #\} stream)) nil *property-path-bounds-readtable*)

5453

(set-syntax-from-char #\, #\space *property-path-bounds-readtable*)

5454

(set-syntax-from-char #\} #\) *property-path-bounds-readtable*)

5455

5456

(defun read-iri-or-blank-node (stream char)

5457

;;!! this will not interact well with suppressed reads

5458

(declare (ignore char))

5459

(case (peek-char nil stream)

5460

((#\space #\tab #\return #\linefeed #\))

5461

(intern "<" *package*))

5462

(#\=

5463

(read-char stream)

5464

(intern "<=" *package*))

5465

(t

5466

(let* ((iri-string (read-buffer stream #'(lambda (c) (not (eql c #\>))))))

5467

(read-char stream)

5468

(let* ((colon-position (position #\: iri-string))

5469

(prefix (when colon-position (subseq iri-string 0 colon-position))))

5470

(if (equal prefix "_")

5471

(let ((node (spocq:make-blank-node (subseq iri-string 2))))

5472

;; construct a new node and mark it as constant

5473

(setf (spocq:blank-node-constant-p node) t)

5474

node)

5475

(let* ((package (when prefix (find-package prefix)))

5476

(iri (or (and (member package *iri-packages*)

5477

                               (find-symbol (subseq iri-string (1+ colon-position)) package))

5478

(intern-iri iri-string)))

5479

(next (peek-char nil stream nil nil)))

5480

(case next

5481

(#\*

5482

(read-char stream)

5483

               (make-bounded-property-path :element (make-property-path-verb :iri iri) :min 0 :max nil))

5484

(#\?

5485

(read-char stream)

5486

               (make-bounded-property-path :element (make-property-path-verb :iri iri) :min 0 :max 1))

5487

(#\+

5488

(read-char stream)

5489

               (make-bounded-property-path :element (make-property-path-verb :iri iri) :min 1 :max nil))

5490

(#\{ (let* ((*readtable* *property-path-bounds-readtable*)

5491

(bounds (read stream)))

5492

(destructuring-bind (min &optional (max nil)) bounds

5493

                       (make-bounded-property-path :element (make-property-path-verb :iri iri) :min min :max max))))

5494

(#\| (make-or-property-path :elements (list iri (read stream))))

5495

(#\/ (make-sequence-property-path :elements (list iri (read stream))))

5496

(t iri)))))))))

5497

;;; nyi !<path> and ^<path>

5498

(set-packaged-macro-character #\< 'read-iri-or-blank-node)

5499

5500

(defun read-variable (stream char)

5501

"Read a variable. If the package is distinguished handle case as per readtable.

5502

Otherwise, preserve the case"

5503

(declare (ignore char))

5504

(case (peek-char nil stream)

5505

(#\:

5506

(read-char stream)

5507

(when (eql (peek-char nil stream) #\:)

5508

(read-char stream))

5509

;; with colons, observe standard reader for the symbol case

5510

      (let ((name-string (read-buffer stream #'(lambda (c) (not (find c '(#\space #\tab #\return #\linefeed #\page #\nul #\))

5511

                                                                      :test #'eql))))))

5512

(cons-symbol :? name-string)))

5513

(t

5514

;; without colons, take the string literally

5515

      (let ((name-string (read-buffer stream #'(lambda (c) (not (find c '(#\space #\tab #\return #\linefeed #\page #\nul #\))

5516

                                                                      :test #'eql))))))

5517

;; but, as a sparql variable

5518

;(cons-symbol *package* (string char) name-string)

5519

(intern name-string :?)))))

5520

5521

(set-packaged-macro-character #\? 'read-variable)

5522

5523

(defun string-truncate (string length)

5524

(if (<= (length string) length)

5525

string

5526

(let ((truncated (make-array length :fill-pointer 0 :element-type 'character))

5527

(max (- length 2)))

5528

(loop for i below max

5529

for c across string

5530

do (vector-push c truncated))

5531

(when (= (length truncated) max)

5532

(dotimes (x 2) (vector-push #\. truncated)))

5533

truncated)))

5534

;;; (loop for i below 7 collect (string-truncate "asdfq" i))

5535

5536

(deftype repository-string () '(satisfies repository-string-p))

5537

5538

(defgeneric repository-string-p (string)

5539

(:method ((object t))

5540

nil)

5541

(:method ((string string))

5542

     (let ((scanner (load-time-value (cl-ppcre:create-scanner "^[A-Za-z_][A-Za-z0-9_-]*/[A-Za-z0-9_][A-Za-z0-9_-]*$"))))

5543

(and (cl-ppcre:scan scanner string) t))))

5544

;;; (repository-string-p "jhacker/foaf")

5545

;;; (and (not (repository-string-p "jhacker/9foaf")) (not (repository-string-p "jhacker/ foaf")))

5546

5547

(deftype email-string () '(satisfies email-string-p))

5548

5549

(defgeneric email-string-p (string)

5550

(:method ((object t))

5551

nil)

5552

(:method ((string string))

5553

     (let ((scanner (load-time-value (cl-ppcre:create-scanner "^[A-Za-z0-9._%+-]+@(?:[A-Za-z0-9-]+\\.)+[A-Za-z]{2,}$"))))

5554

(and (cl-ppcre:scan scanner string) t))))

5555

;;; (email-string-p "a@x.asd")

5556

;;; (email-string-p "a@x.asd.qwer")

5557

;;; (email-string-p "a@x.a")

5558

5559

;;; rfc 3986 via puri

5560

5561

(defgeneric url-string-p (string &key schemes)

5562

(:method ((object t) &key &allow-other-keys)

5563

nil)

5564

(:method ((string string) &key (schemes '("http" "https" "ftp")))

5565

(multiple-value-bind (scheme host port path query fragment userinfo)

5566

(puri::parse-uri-string string)

5567

(declare (ignore port path query fragment userinfo))

5568

(and (or (and (null scheme) (null schemes))

5569

(member scheme schemes :test #'string-equal))

5570

host

5571

t))))

5572

5573

;;; rfc 822, 2822, 1123 in simplified form for memento

5574

5575

(defparameter *rfc1123-date-time-scanner*

5576

   (cl-ppcre:create-scanner "([a-zA-z]{3}), ([0-9]{1,2}) ([a-zA-z]{3}) ([0-9]{4}) ([0-9]{2}):([0-9]{2}):([0-9]{2}) GMT"))

5577

;;; (nth-value 1 (cl-ppcre:scan-to-strings *rfc1123-date-time-scanner* "Wed, 30 May 2007 18:47:52 GMT"))

5578

;;; (nth-value 1 (cl-ppcre:scan-to-strings *rfc1123-date-time-scanner* "Mon, 9 Mar 2020 11:25:06 GMT"))

5579

5580

(defun parse-rfc1123 (value &key junk-allowed)

5581

   "given a timestamp encoded as rfc1123, which means rfc822bis, deconstruct it, convert the elements and

5582

encode it is a universal-time"

5583

   (let ((substrings (coerce (nth-value 1 (cl-ppcre:scan-to-strings *rfc1123-date-time-scanner* value)) 'list)))

5584

(if substrings

5585

(destructuring-bind (wkday day month year hour minute second)

5586

substrings

5587

(declare (ignore wkday))

5588

(encode-universal-time (parse-integer second)

5589

(parse-integer minute)

5590

(parse-integer hour)

5591

(parse-integer day)

5592

(date:decode-month-name month)

5593

(parse-integer year)

5594

0))

5595

(unless junk-allowed

5596

(error "Invalid rdf1123 date-time: ~s." value)))))

5597

;;; (spocq.e:date-time (parse-rfc1123 "Wed, 30 May 2007 18:47:52 GMT"))

5598

;;; (parse-rfc1123 "Wed, 30 May 2007 18:47:5 GMT" :junk-allowed t)

5599

;;; (ignore-errors (parse-rfc1123 "Wed, 30 May 2007 18:47:5z GMT"))

5600

5601

(defgeneric encode-rfc1123 (value &optional stream)

5602

(:method ((value integer) &optional (stream nil))

5603

(multiple-value-bind (second minute hour day month year weekday)

5604

(decode-universal-time value 0)

5605

(format stream "~a, ~d ~:(~a~) ~4,'0d ~2,'0d:~2,'0d:~2,'0d GMT"

5606

               (date:day-in-week-name weekday 3) day (date:month-name month 3) year hour minute second)))

5607

(:method ((value spocq:date-time) &optional stream)

5608

(encode-rfc1123 (date-time-universal-time value) stream)))

5609

;;; (encode-rfc1123 (get-universal-time))

5610

;;; (encode-rfc1123 (spocq.e:now))

5611

5612

5613

;;; external library management

5614

;;; this serves to relocate the libraries from whatever location they may have been

5615

;;; found at the time the system is built, to where they happen to be when the system starts.

5616

;;;

5617

;;; to that end, the cffi registry is scanned, the libraries are unloaded and the names are saved,

5618

;;; but not the paths. then, upon restart the intended runtime locations are searched to

5619

;;; reload.

5620

;;; nb. both locations are present in the foreign library search path

5621

;;; to permit reloading for progressive builds as well as the eventual production start

5622

5623

(let ((library-pathname-list ()))

5624

(defun unload-libraries (&key (verbose *load-verbose*))

5625

(when verbose (warn "unloading libraries..."))

5626

(setf library-pathname-list

5627

(loop for library in (cffi:list-foreign-libraries)

5628

collect (pathname (file-namestring (cffi:foreign-library-pathname library)))

5629

do (cffi:close-foreign-library library)

5630

             when verbose do (warn "unloaded: ~s (~s)" library (cffi:foreign-library-pathname library)))))

5631

(defun reload-libraries (&key (search-path *foreign-library-search-path*))

5632

(setq cffi:*foreign-library-directories* search-path)

5633

(setq clsql-sys:*foreign-library-search-paths* search-path)

5634

(handler-bind ((style-warning #'muffle-warning))

5635

(loop for pathname in library-pathname-list

5636

do (cffi:load-foreign-library pathname)))))

5637

#+sbcl

5638

(pushnew 'reload-libraries sb-ext:*init-hooks*)

5639

5640

5641

;;;

5642

;;; optimization components

5643

;;;

5644

;;; alpha conversion: canonical order, variable renaming

5645

5646

(defun anonymous-triple-preceeds (triple1 triple2)

5647

(let ((*enable-sort-precedence* t))

5648

;; sort triples according to criteria

5649

;; - variable count

5650

;; - standard < comparison for patterns w/o variables

5651

(flet ((term-preceeds (term1 term2)

5652

(ignore-errors (spocq.e:< term1 term2)))

5653

(term-equal (term1 term2)

5654

(ignore-errors (spocq.e:= term1 term2))))

5655

(or (< (count-if #'null triple1) (count-if #'null triple2))

5656

(and (= (count-if #'null triple1) (count-if #'null triple2))

5657

(loop for term1 in (rest triple1)

5658

for term2 in (rest triple2)

5659

if (term-preceeds term1 term2)

5660

do (return t)

5661

else unless (term-equal term1 term2)

5662

do (return nil)

5663

finally (return nil)))))))

5664

5665

(defparameter *abstract-triple-mode* :abstract-variables)

5666

5667

(defun anonymize-triple (triple)

5668

(ecase *abstract-triple-mode*

5669

(:abstract-object

5670

(destructuring-bind (op s p o . rest) triple

5671

(declare (ignore o)) ; always abstract the object value

5672

`(,op

5673

,(if (variable-p s) nil s)

5674

,(if (variable-p p) nil p)

5675

nil

5676

,@rest)))

5677

(:abstract-variables

5678

(cons (first triple) (substitute-if nil #'variable-p (rest triple))))))

5679

5680

5681

5682

(defun abstract-bgp (bgp)

5683

(let* ((ordered-triples (sort (copy-list (rest bgp)) #'anonymous-triple-preceeds

5684

:key #'anonymize-triple))

5685

(variables (append (reverse (expression-variables bgp))

5686

(case *abstract-triple-mode*

5687

(:abstract-object

5688

                                (remove-duplicates (mapcar #'statement-object (rest bgp))

5689

                                                   :test #'equalp)))))

5690

(canonical-variables (loop for i from 0 below (length variables)

5691

                                     collect (cons-symbol :? "VAR" (prin1-to-string i))))

5692

(dictionary (mapcar #'cons variables canonical-variables)))

5693

;; (print variables)

5694

;; (pprint dictionary)

5695

(values (cons (first bgp) (sublis dictionary ordered-triples :test #'equalp))

5696

dictionary)))

5697

5698

;;; (abstract-bgp '(bgp (spocq.a:|triple| ?::v1 "asdf" 2) (spocq.a:|triple| ?::v1 "asdf" 3)))

5699

;;; (abstract-bgp '(bgp (spocq.a:|triple| ?::v1 "asdf" 2) (spocq.a:|triple| ?::v1 "asde" 2)))

5700

 ;;; (abstract-bgp `(bgp (spocq.a:|triple| ?::v1 "asdf" 2) (spocq.a:|triple| ?::v1 "asdf" ,(puri:uri "http://test/"))))

5701

 ;;; (abstract-bgp `(bgp (spocq.a:|triple|  ?::v1 "asdf" _::b1) (spocq.a:|triple| ?::v1 "asdf" ,(puri:uri "http://test/"))))

5702

5703

;;;

5704

;;; predicates used to match query components

5705

;;; the general operators require the query class definition

5706

5707

(defun order-modifier-form-p (object)

5708

(and (consp object)

5709

(member (first object) '(spocq.a:|desc| spocq.a:|asc|))

5710

t))

5711

5712

(defun concise-bounded-description-describe-form-p (value)

5713

(if (member value '(|urn:dydra|:|simple-symmetric-concise-bounded-description|

5714

|urn:dydra|:|simple-concise-bounded-description|

5715

|urn:dydra|:|simple-inverse-concise-bounded-description|))

5716

t nil))

5717

5718

(defun context-term-p (value)

5719

(if (member value '(|urn:dydra|:|all|

5720

|urn:dydra|:|default|

5721

|urn:dydra|:|named|))

5722

t nil))

5723

5724

(defun undefined-variable-behavior-p (value)

5725

(if (member value '(|urn:dydra|:|error|

5726

|urn:dydra|:|warning|

5727

|urn:dydra|:|dynamicBinding|))

5728

t nil))

5729

5730

5731

(defun elementary-bgp-statement-form-p (object)

5732

"return true for triple pattern statements."

5733

(triple-form-p object))

5734

5735

(defun extended-bgp-statement-form-p (object)

5736

"return true for triple pattern statements with extension operators"

5737

(and (triple-form-p object)

5738

(extension-operator-p (third object))))

5739

5740

(defun logical-bgp-statement-form-p (form)

5741

"return true for pattern statement which are just one of the logical combinations."

5742

(or (sum-form-p form)

5743

(and-form-p form)

5744

(or-form-p form)

5745

(not-form-p form)

5746

(union-form-p form)))

5747

5748

(defun bgp-statement-form-p (object)

5749

"return true elementary and compound logical bgp statements."

5750

(or (elementary-bgp-statement-form-p object)

5751

(logical-bgp-statement-form-p object)))

5752

5753

(defun bgp-pattern-form-p (form)

5754

"return true for any form which serves to match or filter within a bgp."

5755

(or (bgp-statement-form-p form)

5756

(filter-form-p form)))

5757

5758

(defun bgp-state-form-p (form)

5759

(and (triple-form-p form)

5760

(not (state-predicate-p (third form)))))

5761

5762

(defun agp-generator-form-p (form)

5763

(and (consp form) (eq (first form) 'agp-generator)))

5764

5765

(defun built-in-sse-form-p (form)

5766

(and (consp form)

5767

(member (first form)

5768

'(spocq.a:|abs| spocq.a:|add| spocq.a:|avg|

5769

                  spocq.a:|bound| spocq.a:|cardinality| spocq.a:|ceil| spocq.a:|concat| spocq.a:|contains| spocq.a:|count|

5770

spocq.a:|datatype| spocq.a:|day|

5771

spocq.a:|encode_for_uri| spocq.a:|exists|

5772

spocq.a:|floor|

5773

spocq.a:|group_concat|

5774

spocq.a:|hours|

5775

                  spocq.a:|if| spocq.a:|in| spocq.a:|iri| spocq.a:|isBlank| spocq.a:|isLiteral| spocq.a:|isIRI| spocq.a:|isURI|

5776

5777

5778

spocq.a:|not| spocq.a:|notin| spocq.a:|now|

5779

spocq.a:|or|

5780

5781

                  spocq.a:|sameTerm| spocq.a:|sample| spocq.a:|seconds| spocq.a:|sha1| spocq.a:|sha224| spocq.a:|sha256| spocq.a:|sha384| spocq.a:|sha512|

5782

                  spocq.a:|str| spocq.a:|strafter| spocq.a:|strbefore| spocq.a:|strends| spocq.a:|strdt| spocq.a:|strlang| spocq.a:|strlen| spocq.a:|strstarts| spocq.a:|substr| spocq.a:|sum|

5783

spocq.a:|timezone|

5784

5785

spocq.a:|year|

5786

                  spocq.a:|+| spocq.a:|!| spocq.a:|-|  spocq.a:|=| spocq.a:|!=| spocq.a:|<| spocq.a:|>| spocq.a:|<=| spocq.a:|>=| spocq.a:|*| spocq.a:|/| spocq.a:|_|

5787

))))

5788

5789

(defun conditional-sse-form-p (form)

5790

(and (consp form)

5791

(member (first form)

5792

                '(spocq.a:|and| spocq.a:|&&| spocq.a:|or| spocq.a:\|\| spocq.a:|!| spocq.a:|not|))))

5793

5794

(defun arithmetic-sse-form-p (form)

5795

(and (consp form)

5796

(member (first form)

5797

'(spocq.a:|+| spocq.a:|-| spocq.a:|*| spocq.a:|/|))))

5798

5799

(defun construct-form-template (form)

5800

(when (consp form)

5801

(third form)))

5802

5803

(defun functional-sse-form-p (form)

5804

(and (consp form)

5805

(iri-p (first form))))

5806

5807

(defun relational-sse-form-p (form)

5808

(and (consp form)

5809

(member (first form)

5810

                '(spocq.a:|=| spocq.a:|!=| spocq.a:|<| spocq.a:|>| spocq.a:|<=| spocq.a:|>=| spocq.a:|in| spocq.a:|notin| ))))

5811

5812

5813

;;;

5814

;;; compute subexpressions

5815

;;;

5816

;;; given the collected bgp forms, canonicalize them, create a subsequence concordance.

5817

;;; select the maximal, non-overlapping subsequences. (<- does not work since varying constituency

5818

;;; leads to interleaved patterns.)

5819

;;; replace those with named sub-bgps

5820

;;;

5821

;;; for each pattern, record the containing bgps,

5822

 ;;; invert that and for each bgp combo ;;; record the included patterns. do this also for single pattern occurrences.

5823

 ;;; trim this collection by removing patterns - both single and combination elements, which also appear in a

5824

;;; larger combination.

5825

;;; replace combinations wherever they appear with a sub-bgp. single elements are left unchanged.

5826

5827

(defparameter *pattern-concordance* nil)

5828

5829

(defstruct bgpse bgp-set pattern-set)

5830

5831

(defun bgpse-bgp-cardinality (bgpse) (length (bgpse-bgp-set bgpse)))

5832

(defun bgpse-pattern-cardinality (bgpse) (length (bgpse-pattern-set bgpse)))

5833

(defun bgpse-add-pattern (bgpse pattern) (pushnew pattern (bgpse-pattern-set bgpse) :test #'equal))

5834

(defun bgpse-add-bgp (bgpse bgp) (pushnew bgp (bgpse-bgp-set bgpse) :test #'equal))

5835

5836

(defparameter *bgpse-factors*

5837

`((1 . bgpse-bgp-cardinality)

5838

(1 . bgpse-pattern-cardinality))

5839

   "An a-list of numeric factors and function which compute the preference for a given bgp subexpression

5840

  for a particular criteria. The global spec includes just two factors, evenly weighted, for the bgp set

5841

  cardinality and pattern set cardinality. When supplied in connection with an active query - for which the

5842

repository can serve as a source of selectivity, an aditional component is included to include the

5843

selectivity.")

5844

5845

(defun bgpse-priority (bgpse)

5846

(loop for (factor . function) in *bgpse-factors*

5847

sum (* factor (funcall function bgpse))))

5848

5849

(defun rewrite-common-bgps (bgps &key (sort-key #'bgpse-priority) ((:factors *bgpse-factors*) *bgpse-factors*)

5850

(verbose nil))

5851

(let ((canonical-bgps (mapcar #'abstract-bgp bgps))

5852

(pattern-2-bgps (make-hash-table :test 'equalp))

5853

(bgps-2-patterns (make-hash-table :test 'equalp))

5854

         (combinations ())               ; alist of (bgps . patterns) of where the patterns appear

5855

(sorted-combinations ()) ; that alist sorted by sort-key

5856

(minimum-combinations ()) ; the minimum set sufficient to match all combinations

5857

)

5858

(labels ((register-patterns (bgp)

5859

(dolist (pattern (rest bgp))

5860

(push bgp (gethash pattern pattern-2-bgps))))

5861

(combine-patterns (pattern bgps)

5862

(push pattern (gethash bgps bgps-2-patterns))))

5863

(when verbose

5864

(pprint-sse bgps)

5865

(pprint-sse canonical-bgps))

5866

(dolist (bgp canonical-bgps)

5867

(register-patterns bgp))

5868

(maphash #'combine-patterns pattern-2-bgps)

5869

(maphash #'(lambda (bgps patterns)

5870

                    ;; if the patterns appear in more than one bgp, cinlude them in the process

5871

(when (rest bgps)

5872

(push (make-bgpse :bgp-set bgps :pattern-set patterns) combinations)))

5873

bgps-2-patterns)

5874

(setf sorted-combinations (sort combinations #'> :key sort-key))

5875

(setf minimum-combinations (remove-if #'(lambda (bgpse)

5876

                                                 (let ((predecessors (ldiff combinations (member bgpse sorted-combinations))))

5877

                                                   (every #'(lambda (p)

5878

                                                              (some #'(lambda (p-bgpse) (member p (bgpse-pattern-set p-bgpse)))

5879

                                                                          predecessors))

5880

                                                                (bgpse-pattern-set bgpse))))

5881

sorted-combinations :from-end t))

5882

;; (aprint minimum-combinations)

5883

(loop for bgpse in minimum-combinations

5884

for bgps = (bgpse-bgp-set bgpse)

5885

for patterns = (bgpse-pattern-set bgpse)

5886

do (dolist (bgp bgps)

5887

(unless (null (set-difference patterns (rest bgp) :test #'equalp))

5888

(error "~%~%mismatch? :~%~s~%~s"

5889

bgp patterns))

5890

;; (format *trace-output* "~%bgp before : ~s~%sub : ~s" bgp patterns)

5891

(setf (rest bgp)

5892

`((spocq.a::|sub-bgp| ,@patterns)

5893

,@(set-difference (rest bgp) patterns :test #'equalp)))

5894

;;(format *trace-output* "~%bgp after : ~s" bgp)

5895

))

5896

canonical-bgps)))

5897

5898

(defstruct pprint-variable symbol)

5899

(defstruct pprint-triple terms)

5900

5901

(defmethod print-object ((object pprint-variable) (stream t))

5902

(format stream "?~a" (pprint-variable-symbol object)))

5903

(defmethod print-object ((object pprint-triple) (stream t))

5904

(let ((*print-pretty* nil))

5905

(format stream "{~{~s~^ ~}}" (pprint-triple-terms object))))

5906

5907

(defparameter *pprint-sse-package* (or (find-package :sse-package) (make-package :sse-package :use nil)))

5908

(loop for symbol being each external-symbol of :spocq.a

5909

do (import symbol *pprint-sse-package*) (export symbol *pprint-sse-package*))

5910

(loop for symbol being each external-symbol of :spocq.e

5911

do (unless (find-symbol (string symbol) *pprint-sse-package*)

5912

(import symbol *pprint-sse-package*) (export symbol *pprint-sse-package*)))

5913

(loop for symbol being each external-symbol of :common-lisp

5914

unless (find-symbol (string symbol) *pprint-sse-package*)

5915

do (import symbol *pprint-sse-package*) (export symbol *pprint-sse-package*))

5916

(loop for symbol being each external-symbol of :spocq.i

5917

unless (find-symbol (string symbol) *pprint-sse-package*)

5918

do (import symbol *pprint-sse-package*) (export symbol *pprint-sse-package*))

5919

(import 'cl:nil *pprint-sse-package*)

5920

(export 'cl:nil *pprint-sse-package*)

5921

5922

(defun pprint-sse (form &optional (stream *standard-output*))

5923

(let ((*package* *pprint-sse-package*)

5924

(*readtable* *sse-readtable*))

5925

(labels ((make-pprint-object (term)

5926

(cond ((variable-p term)

5927

(make-pprint-variable :symbol term))

5928

((spocq:boolean-p term)

5929

(if (spocq:boolean-value term) 'spocq.a:|true| 'spocq.a:|false|))

5930

((triple-form-p term)

5931

                       (make-pprint-triple :terms (mapcar #'make-pprint-object (rest term))))

5932

((and (symbolp term) (iri-p term))

5933

(spocq:make-iri (iri-lexical-form term)))

5934

(t

5935

term))))

5936

(setf form (map-tree #'make-pprint-object form))

5937

(write form :stream stream :pretty t :right-margin 120 :miser-width 20 :case :downcase))

5938

(values)))

5939

5940

 ;;; (pprint (mapcar #'abstract-bgp (query-bgps #p"P-LIBRARY:org;datagraph;spocq;src;test;rspec;tests;data-sp2b;q7.sparql")))

5941

5942

;;;

5943

;;; property paths

5944

5945

(defstruct verb)

5946

(defstruct (stative-verb (:include verb)))

5947

(defstruct (property-path (:include stative-verb)))

5948

(defstruct (property-path-verb (:include property-path))

5949

iri value

5950

query

5951

solution-generator)

5952

(defstruct (unary-property-path (:include property-path))

5953

element)

5954

(defstruct (nary-property-path (:include property-path))

5955

elements)

5956

5957

(defstruct (and-property-path (:include nary-property-path)))

5958

(defstruct (bounded-property-path (:include unary-property-path))

5959

min

5960

max)

5961

(defstruct (inverted-property-path (:include unary-property-path)))

5962

(defstruct (negated-property-path (:include unary-property-path)))

5963

(defstruct (or-property-path (:include nary-property-path)))

5964

(defstruct (sequence-property-path (:include nary-property-path)))

5965

(defstruct (zero-length-property-path (:include unary-property-path)))

5966

5967

(defstruct (active-verb (:include verb))

5968

parameters

5969

results)

5970

5971

(defstruct (view-verb (:include active-verb))

5972

"Encapsulate a view reference as a statement pattern predicate

5973

Include the parameter and result dimensions"

5974

url

5975

query

5976

result-map)

5977

5978

(defstruct (function-verb (:include active-verb))

5979

"Encapsulate a function reference as a statement pattern predicate

5980

Include the parameter and result dimensions.

5981

Either function call/return or continuation passsing serves as the linkage mechanism,

5982

depending on the wrapped function type."

5983

function)

5984

5985

(defgeneric implies-bounded-property-path (verb)

5986

(:method ((verb t)) nil)

5987

(:method ((verb bounded-property-path)) t)

5988

(:method ((verb unary-property-path)) (implies-bounded-property-path (unary-property-path-element verb)))

5989

   (:method ((verb nary-property-path)) (some #'implies-bounded-property-path (nary-property-path-elements verb))))

5990

5991

;;; active-verb operators

5992

5993

(defclass function-verb-function (standard-generic-function)

5994

()

5995

(:metaclass c2mop:funcallable-standard-class))

5996

5997

(defmethod make-load-form ((object view-verb) &optional env)

5998

(declare (ignore env))

5999

(values `(make-view-verb :url ,(view-verb-url object)

6000

:parameters ',(view-verb-parameters object)

6001

:results ',(view-verb-results object))

6002

nil))

6003

6004

(defmethod make-load-form ((object function-verb) &optional env)

6005

(declare (ignore env))

6006

(values `(make-function-verb :function ',(function-verb-function object)

6007

:parameters ',(function-verb-parameters object)

6008

:results ',(function-verb-results object))

6009

nil))

6010

6011

(defgeneric invoke-active-verb (active-verb repository-handle continuation &rest arguments)

6012

(:documentation "invoke the verb's implementation arranging to pass the arguments to the

6013

invocation and pass the results to the continuation.")

6014

6015

(:method ((verb symbol) transaction continuation &rest arguments)

6016

     "A function verb invokes the respective function directly and apply the continuation to the result."

6017

(declare (dynamic-extent arguments))

6018

(cond ((fboundp verb)

6019

(apply #'invoke-active-verb (symbol-function verb) transaction continuation arguments))

6020

(t ; shouldn't happen

6021

(log-warn "invoke-active-verb: unbound function: ~s" verb)

6022

(error 'undefined-function :name verb))))

6023

6024

(:method ((verb function-verb) transaction continuation &rest arguments)

6025

     "A function verb invokes the respective function directly and apply the continuation to the result."

6026

(declare (dynamic-extent arguments))

6027

(apply #'invoke-active-verb (function-verb-function verb) transaction continuation arguments))

6028

6029

(:method ((function function) transaction continuation &rest arguments)

6030

"Once resolved to a simple function, apply it, collect the results and continue with those.

6031

      This is intended for feneral operators, for which the transaction does not appear among the arguments."

6032

(declare (dynamic-extent arguments))

6033

(multiple-value-call continuation (apply function arguments)))

6034

6035

(:method ((function function-verb-function) transaction continuation &rest arguments)

6036

"A function-verb function is invoked by supplying both the continuation and the transaction

6037

     as well as the actual arguments, to allow it to govern invocation of the continuation to (repeated) results."

6038

(declare (dynamic-extent arguments))

6039

(apply function continuation transaction arguments))

6040

6041

(:method ((verb view-verb) transaction continuation &rest arguments)

6042

"Each verb instance - that is, each call site, must generate its own execution graph.

6043

In order to accomplish that, each generates its own query to mediate the sub-select.

6044

This query is initialized once, which compiles its initialization function.

6045

For each invocation, that function is invoked anew to return a new solution generator as the

6046

head of a new execution graph.

6047

The invocation establishes the sip arguments as dynamic bindings, initiates the query and

6048

passes each result solution to the continuation in turn - with necessary dimension mapping.

6049

6050

(adapted from run-sip-service-step and compute-pattern-graph-names)"

6051

(declare (dynamic-extent arguments))

6052

(let ((query (view-verb-query verb)))

6053

(unless query

6054

(let ((service-repository (service-repository (view-verb-url verb))))

6055

(unless (equalp (repository-id service-repository) (repository-id *repository*))

6056

(error "inter-repository view: ~s -- ~s"

6057

(repository-id service-repository) (repository-id *repository*)))

6058

(let* ((view-name (repository-resource-view-name service-repository (view-verb-url verb)))

6059

                  (query-text (or (authorized-repository-view service-repository view-name (task-agent *task*))

6060

                                       (spocq.e:resource-not-found-error :identifier (view-verb-url verb))))

6061

(query-expression (parse-sparql query-text)))

6062

(setf query (make-query :sse-expression query-expression

6063

:id (make-service-task-id)

6064

:dynamic-bindings nil

6065

                                     :repository-id (repository-id service-repository)

6066

:revision-id "HEAD"

6067

:user-id nil

6068

:sparql-expression query-text

6069

:agent (system-agent)

6070

:parent-task nil

6071

                                     :response-content-type mime:application/sparql-results+json))))

6072

(initialize-task query)

6073

(setf (view-verb-query verb) query))

6074

(with-task-environment (:task query)

6075

(with-open-repository ((task-repository query))

6076

(let* ((generator (funcall (task-initialization-function query) query))

6077

(expression (solution-generator-expression generator))

6078

(channel (solution-generator-channel generator))

6079

(continuation-dimensions (view-verb-results verb))

6080

(result-dimensions (solution-generator-dimensions generator))

6081

(bindings (cons result-dimensions arguments))

6082

(result-map (view-verb-result-map verb))

6083

(count 0))

6084

(unless result-map

6085

               (setf result-map (loop for dim in result-dimensions  collect (position dim continuation-dimensions)))

6086

(setf (view-verb-result-map verb) result-map))

6087

(setf (task-dynamic-bindings query) bindings)

6088

(query-run-in-thread query expression)

6089

(do-pages (solutions channel)

6090

(loop for index from 0 below (array-dimension solutions 0)

6091

with args = (make-list (length result-map))

6092

do (loop for args-list on args by #'cdr

6093

for position in result-map

6094

                              do (setf (first args-list) (aref solutions index position))

6095

finally (apply continuation args))

6096

do (incf count)))

6097

count))))))

6098

6099

#+(or)

6100

( ;; testing subquery execution time: x10 = ca 170ms

6101

(let* ((text "select count(*) where {?s ?p ?o}")

6102

(repository "james/test")

6103

(query (make-query :sse-expression (parse-sparql text)

6104

:id (make-service-task-id)

6105

:dynamic-bindings nil

6106

:repository-id repository

6107

:revision-id "HEAD"

6108

:user-id nil

6109

:sparql-expression text

6110

:agent (system-agent)

6111

:parent-task nil

6112

:response-content-type mime:application/sparql-results+json)))

6113

(initialize-task query)

6114

(flet ((run-query ()

6115

(with-task-environment (:query query)

6116

(with-open-repository ((task-repository query))

6117

6118

(let* ((generator (funcall (task-initialization-function query) query))

6119

(expression (solution-generator-expression generator))

6120

(channel (solution-generator-channel generator))

6121

(results ()))

6122

(query-run-in-thread query expression)

6123

(do-pages (solutions channel)

6124

                            (setf results (append results (term-value-field solutions))))

6125

results)))))

6126

(time (loop for i below 10

6127

collect (list i (run-query))))))

6128

6129

(time (loop for i below 10

6130

             collect (list i (test-sparql "select count(*) where {?s ?p ?o}" :repository-id "james/test"))))

6131

)

6132

6133

;;; property path operators

6134

6135

(defun property-path-element (path) (unary-property-path-element path))

6136

(defun property-path-elements (path) (nary-property-path-elements path))

6137

(defun property-path-max (path) (bounded-property-path-max path))

6138

(defun property-path-min (path) (bounded-property-path-min path))

6139

6140

;; define load forms as required for tests

6141

(defmethod make-load-form ((object property-path-verb) &optional env)

6142

(declare (ignore env))

6143

(values `(make-property-path-verb :iri ,(property-path-verb-iri object))

6144

nil))

6145

6146

(defmethod make-load-form ((object bounded-property-path) &optional env)

6147

(declare (ignore env))

6148

(values `(make-bounded-property-path :min ,(bounded-property-path-min object)

6149

                                        :max ,(bounded-property-path-max object)

6150

                                        :element ,(bounded-property-path-element object))

6151

nil))

6152

6153

(defun make-list-property-path ()

6154

   (make-sequence-property-path :elements (list (make-bounded-property-path :element (make-property-path-verb :iri |rdf|:|rest|) :min 0 :max nil)

6155

                                                (make-property-path-verb :iri |rdf|:|first|))))

6156

6157

(defmethod expression-variables ((path unary-property-path))

6158

(expression-variables (unary-property-path-element path)))

6159

6160

(defmethod expression-variables ((path nary-property-path))

6161

(expression-variables (nary-property-path-elements path)))

6162

6163

6164

(defmethod expression-predicates ((path property-path-verb))

6165

(list (property-path-verb-iri path)))

6166

6167

(defmethod expression-predicates ((path unary-property-path))

6168

(expression-predicates (unary-property-path-element path)))

6169

6170

(defmethod expression-predicates ((path nary-property-path))

6171

(reduce #'union (nary-property-path-elements path) :key #'expression-predicates))

6172

6173

#+(or)

6174

(defmethod print-object :around ((object property-path) stream)

6175

(call-next-method))

6176

6177

(defmethod print-object ((object property-path-verb) stream)

6178

(format stream "<~/format-sse-iri-namestring/>" (property-path-verb-iri object)))

6179

6180

(defmethod print-object ((object and-property-path) stream)

6181

(format stream "(~{~s~^&~})" (property-path-elements object)))

6182

6183

(defmethod print-object ((object bounded-property-path) stream)

6184

(princ (property-path-element object) stream)

6185

(let ((min (property-path-min object))

6186

(max (property-path-max object)))

6187

(cond ((and (eql min 0) (null max))

6188

(write-char #\* stream))

6189

((and (eql min 0) (eql max 1))

6190

(write-char #\? stream))

6191

((and (eql min 1) (null max))

6192

(write-char #\+ stream))

6193

(t

6194

(format stream "{~@[~a~],~@[~a~]}" min max)))))

6195

6196

(defmethod print-object ((object inverted-property-path) stream)

6197

(format stream "^~s" (property-path-element object)))

6198

6199

(defmethod print-object ((object negated-property-path) stream)

6200

(format stream "!~s" (property-path-element object)))

6201

6202

(defmethod print-object ((object or-property-path) stream)

6203

(format stream "(~{~s~^|~})" (property-path-elements object)))

6204

6205

(defmethod print-object ((object sequence-property-path) stream)

6206

(format stream "(~{~s~^/~})" (property-path-elements object)))

6207

6208

(defmethod print-object ((object zero-length-property-path) stream)

6209

(format stream "~s{0,0}" (property-path-element object)))

6210

6211

6212

;;;

6213

;;; declarations

6214

6215

6216

(define-declaration spocq.e:base-dimensions (declaration &optional env)

6217

"Specify the dimensions expected to be available in the dynamic extent of the

6218

body evaluation. Intended for bgp, such that they are compiled to accept such a source

6219

and provide a propagation channel to be linked with that source during reduction."

6220

6221

(destructuring-bind (tag . dimensions) declaration

6222

(assert (every #'symbolp dimensions))

6223

(let ((old (when env (declaration-information 'spocq.e:base-dimensions env))))

6224

(values :declare (cons tag (cons dimensions old))))))

6225

6226

(define-declaration spocq.e::cardinality (declaration &optional env)

6227

"Specify the estimated cardinality for some form.

6228

Used in particular when compiling bgps.

6229

It is not actually passed trhough the compiler, just from the macroexpansion

6230

to the step which compiles the bgp."

6231

6232

(declare (ignore env))

6233

(destructuring-bind (tag cardinality) declaration

6234

(values :declare (list tag cardinality))))

6235

6236

(define-declaration spocq.e:dimensions (declaration &optional env)

6237

"Specify the dimensions available within an extant reduction context:

6238

- filter operators internal to a bgp, which need to know how to extract their arguments.

6239

(see exist)"

6240

6241

(destructuring-bind (tag . dimensions) declaration

6242

(let ((old (when env (declaration-information 'spocq.e:dimensions env))))

6243

(values :declare (cons tag (cons dimensions old))))))

6244

6245

(defmacro spocq.e::with-dimensions (dimensions &body body)

6246

`(locally (declare (spocq.e::dimensions ,@dimensions)) ,@body))

6247

6248

(define-declaration spocq.e:join-dimensions (declaration &optional env)

6249

"Assert the dimensions effective for a join operation. Used by

6250

- filter operators internal to the join, which need to know how to extract their arguments,

6251

- bgp compilation to know which dimenions to project."

6252

6253

(declare (ignore env))

6254

(destructuring-bind (tag join left right) declaration

6255

(values :declare (list tag join left right))))

6256

6257

(define-declaration spocq.e::join-scope (declaration &optional env)

6258

"Assert a new join scope - each adds to any outer scope."

6259

(destructuring-bind (tag scope) declaration

6260

(let ((old (when env (declaration-information 'spocq.e::join-scope env))))

6261

(values :declare (list* tag scope old)))))

6262

6263

(defmacro spocq.e::with-join-scope (scope &body body)

6264

`(locally (declare (spocq.e::join-scope ,scope)) ,@body))

6265

6266

(define-declaration spocq.e::processing-mode (declaration &optional env)

6267

"Assert a processing mode.

6268

:synchronous causes the match to happen at the point where the result is to be used.

6269

:asynchronous permits reordered execution and solution propagation among agp instances.

6270

:collated applies to match/scan behaviour of collates statement patterns.

6271

The former is the special case for exist forms."

6272

(declare (ignore env))

6273

(destructuring-bind (tag mode) declaration

6274

(assert (member mode '(:asynchronous :synchronous :collated)) ()

6275

"Invalid processing mode: ~s." mode)

6276

(values :declare (cons tag mode))))

6277

6278

(defmacro spocq.e::with-processing-mode (mode &body body)

6279

`(locally (declare (spocq.e::processing-mode ,mode)) ,@body))

6280

6281

(define-declaration spocq.e:projection-dimensions (declaration &optional env)

6282

"Specify the dimensions intended to be projected.

6283

Used to limit the dimensions in intermediate forms, once they are no longer required.

6284

Overrides any specifications from a outer scope."

6285

(declare (ignore env))

6286

(destructuring-bind (tag . dimensions) declaration

6287

(assert (every #'symbolp dimensions))

6288

(values :declare (cons tag dimensions))))

6289

6290

(define-declaration spocq.e:reference-dimensions (declaration &optional env)

6291

"Specify the dimensions referenced in some form.

6292

Used to indicate field dimensions required by the expression - eg a filter or a binding.

6293

Augments any specifications from a outer scope."

6294

(destructuring-bind (tag . new-dimensions) declaration

6295

(let ((old (when env (declaration-information 'spocq.e::reference-dimensions env))))

6296

(values :declare (list* tag (union-dimensions new-dimensions old))))))

6297

(defmacro spocq.e:with-reference-dimensions (dimensions &body body)

6298

(if dimensions

6299

`(locally (declare (spocq.e:reference-dimensions ,@dimensions)) ,@body)

6300

(if (rest body)

6301

`(locally ,@body)

6302

(first body))))

6303

6304

(define-declaration spocq.e:temporal-attribute (declaration &optional env)

6305

"Capture a temporal attribute which has been articulated in some reference to

6306

a pattern variable. Make it available for the BGP evaluation process to extract it from

6307

the statement revision map."

6308

(destructuring-bind (tag . form) declaration

6309

(let ((old (when env (declaration-information 'spocq.e:temporal-attribute env))))

6310

(values :declare (cons tag (cons form old))))))

6311

6312

(define-declaration spocq.e:version-constraint (declaration &optional env)

6313

"Capture a temporal constraint which has been articulated in some reference to

6314

a pattern variable. Make it available for the BGP evaluation process to apply it to

6315

the statement matching process."

6316

(destructuring-bind (tag form) declaration

6317

(let ((old (when env (declaration-information 'spocq.e:version-constraint env))))

6318

;; allow nil to shadow outer declarations in a sub-select

6319

(values :declare (cons tag (when form (cons form old)))))))

6320

6321

(defmacro spocq.e:with-version-constraint (constraint &body body)

6322

`(locally (declare (spocq.e:version-constraint ,constraint)) ,@body))

6323

6324

6325

(define-declaration spocq.e::sort-order (declaration &optional env)

6326

"Communicate the sort precedence to the current evaluation tree.

6327

For a given quera, there can be at most one set of solution modifiers and of them

6328

at most one order clause."

6329

(destructuring-bind (tag variables) declaration

6330

(let ((old (when env (declaration-information 'spocq.e::sort-order env))))

6331

;; there should be at most one order clause in a query

6332

(when old

6333

(log-warn "Shadowing order precedence: ~s . ~s"

6334

declaration old))

6335

(values :declare (cons tag variables)))))

6336

6337

(defmacro spocq.e::with-sort-order (variables &body body)

6338

(assert (every #'variable-p variables) ()

6339

"Invalid sort order: ~s" variables)

6340

`(locally (declare (spocq.e::sort-order ,variables)) ,@body))

6341

6342

6343

;;;

6344

;;; stream utilities

6345

6346

(defgeneric read-file (file)

6347

(:method ((file pathname))

6348

(with-open-file (stream file :direction :input :element-type '(unsigned-byte 8))

6349

(read-stream stream :length (file-length stream))))

6350

(:method ((file string))

6351

(read-file (pathname file))))

6352

6353

(defgeneric read-stream (stream &key length eof-p limit)

6354

(:documentation

6355

"read the content of a STREAM into a string, with an initial buffer size, LENGTH.

6356

the result string is a simplestring, which has been extended or truncated as appropriate.

6357

a null byte terminates the input")

6358

6359

(:method ((stream stream) &key (length 1024) (eof-p nil) (limit nil))

6360

(let ((buffer (make-array length :adjustable t :fill-pointer 0 :element-type 'character))

6361

(decoder (content-encoding-byte-decoder (content-encoding :utf-8)))

6362

(count 0))

6363

(block :read-bytes

6364

(flet ((utf8-byte-reader (ignore)

6365

(declare (ignore ignore))

6366

(let ((byte (read-byte stream nil nil)))

6367

(cond ((or (null byte) (zerop byte))

6368

(return-from :read-bytes))

6369

((and limit (> (incf count) limit))

6370

(error "read-stream: limit exceeded: ~s" limit))

6371

(t

6372

byte)))))

6373

(declare (dynamic-extent #'utf8-byte-reader))

6374

(loop (vector-push-extend (funcall decoder #'utf8-byte-reader nil) buffer))))

6375

(log-debug "read-stream: ~s." buffer)

6376

(when (and eof-p (zerop (length buffer)))

6377

(error 'end-of-file :stream stream))

6378

(subseq buffer 0 (length buffer)))))

6379

6380

(defun call-with-input-from-vector (operator data &key ((:agent *agent*) *agent*))

6381

(funcall operator (make-instance 'DE.SETF.UTILITY.IMPLEMENTATION::VECTOR-INPUT-STREAM

6382

:vector data)))

6383

6384

(defmacro with-input-from-vector ((stream vector &rest args) &body body)

6385

(let ((op (gensym)))

6386

`(flet ((,op (,stream) ,@body))

6387

(declare (dynamic-extent #',op))

6388

(call-with-input-from-vector #',op ,vector ,@args))))

6389

6390

(defun test-query-loop (query &key (count 1) (task-id nil)

6391

(repository-id (error "repositor-id is required."))

6392

                               (response-content-type mime:application/sparql-results+json)

6393

(request-content-type mime:application/sparql-query)

6394

(api-key nil)

6395

(agent-id nil)

6396

(stream nil))

6397

(unless *run-state* (initialize-spocq))

6398

(let ((input-string (format nil "((:TASK-ID ~s)

6399

(:REPOSITORY-ID ~s)

6400

(:RESPONSE-CONTENT-TYPE ~s)

6401

(:REQUEST-CONTENT-TYPE ~s)

6402

~@[(:API-KEY ~s)~]

6403

~@[(:AGENT-ID ~s)~]

6404

)

6405

~a

6406

"

6407

(or task-id (make-internal-task-id))

6408

repository-id

6409

(string (type-of response-content-type))

6410

(string (type-of request-content-type))

6411

api-key

6412

agent-id

6413

query))

6414

(*agent* (unless (or api-key agent-id) (system-agent)))

6415

(result nil))

6416

(dotimes (i count)

6417

(with-input-from-vector (*standard-input* input-string)

6418

(let ((*request-processor* nil))

6419

(setf result

6420

(if stream

6421

                     (let ((*standard-output* stream)) (main-query-loop) (finish-output stream))

6422

(with-output-to-string (*standard-output*) (main-query-loop)))))))

6423

result))

6424

6425

6426

;;; basic http streamed request support

6427

6428

(defmacro with-http-request-stream ((request-stream response-stream location &rest options) &body body)

6429

(let ((op (gensym "with-http-request-stream-")))

6430

`(flet ((,op (,request-stream ,response-stream)

6431

(declare (ignorable ,request-stream ,response-stream))

6432

,@body))

6433

(declare (dynamic-extent #',op))

6434

(call-with-http-request-stream #',op ,location ,@options))))

6435

6436

6437

(defgeneric http-method-key (key)

6438

(:method ((key string))

6439

     (http-method-key (or (find-symbol (string-upcase key) :keyword) (error "invalid http request method: ~s" key))))

6440

(:method ((key (eql :post)))

6441

key)

6442

(:method ((key (eql :put)))

6443

key)

6444

(:method ((key (eql :get)))

6445

key)

6446

(:method ((key t))

6447

(error "invalid http request method: ~s" key)))

6448

6449

6450

 (defgeneric call-with-http-request-stream (operation location &key method content-type accept content-length follow

6451

                                                      content-pathname)

6452

(:documentation "arrange for a connection to the given http location and invoke the

6453

given operator passing the request or response stream respective the http method.

6454

as implemented, the stream is uni-directional")

6455

   (:method (operation (location string) &key (method "GET") content-type accept content-length content-pathname (follow t))

6456

(let* ((method-key (http-method-key method))

6457

(process (run-program "/usr/bin/curl" ;; "/opt/dydra/lib/exec/curl"

6458

`("-s" "-X" ,(string method-key)

6459

;; "-v"

6460

;; "--trace-ascii" "/dev/stdout"

6461

,@(when follow '("-L"))

6462

                                    ,@(when content-pathname `("--data-binary" ,(format nil "@~a" (namestring content-pathname))))

6463

                                    ,@(when content-type `("-H" ,(format nil "Content-Type: ~a" (mime:mime-type-namestring content-type))))

6464

                                    ,@(when content-length `("-H" ,(format nil "Content-Length: ~a" content-length)))

6465

                                    ,@(when accept `("-H" ,(format nil "Accept: ~a" (mime:mime-type-namestring accept))))

6466

,location)

6467

:wait nil

6468

:output :stream

6469

:input :stream))

6470

(request-stream (run-program-input process))

6471

(response-stream (run-program-output process)))

6472

(unwind-protect (multiple-value-prog1 (funcall operation request-stream response-stream)

6473

(sb-ext:process-wait process))

6474

(run-program-close process))))

6475

6476

(:method (operation (location spocq:iri) &rest args)

6477

(apply #'call-with-http-request-stream operation (spocq:iri-lexical-form location) args)))

6478

6479

(defgeneric file-type-media-type (type &optional error-p)

6480

(:documentation "Return the expected or declared mime type for a given pathname type.

6481

Permit url, pathname and string arguments

6482

LOCATION : (or pathname string url stream)

6483

VALUE : mime:mime-type")

6484

6485

(:method ((location pathname) &optional (error-p t))

6486

"Given a pathname, use its file type"

6487

(file-type-media-type (pathname-type location) error-p))

6488

6489

(:method ((location spocq:iri) &optional (error-p t))

6490

(file-type-media-type (puri:uri location) error-p))

6491

6492

(:method ((location puri:uri) &optional (error-p t))

6493

(let* ((path (puri:uri-path location))

6494

(type (when path (first (last (split-string path "."))))))

6495

(cond (type

6496

(file-type-media-type type error-p))

6497

(error-p

6498

(error "media type not found: ~a" location))

6499

(t nil))))

6500

6501

(:method ((file-type string) &optional (error-p t))

6502

(cond ((gethash file-type (file-type-media-types)))

6503

(error-p

6504

(error "media type not found: ~a" file-type))

6505

(t nil))))

6506

6507

;;; (file-type-media-type #p"test.nq")

6508

6509

(defparameter *file-type-media-types* nil)

6510

(defun file-type-media-types ()

6511

(or *file-type-media-types*

6512

(setq *file-type-media-types*

6513

(compute-file-type-media-types))))

6514

(defun compute-file-type-media-types ()

6515

(let ((cache (make-hash-table :test 'equalp)))

6516

(labels ((cache-type (class)

6517

(let* ((name (class-name class))

6518

(media-type (when (boundp name) (symbol-value name)))

6519

                       (type (when (typep media-type '(and mime:mime-type (not de.setf.utility::delegate-mime-type)))

6520

                               (de.setf.utility.implementation::get-mime-type-file-type media-type))))

6521

(when (and (stringp type) (null (gethash type cache)))

6522

(setf (gethash type cache) media-type))

6523

(loop for subclass in (c2mop:class-direct-subclasses class)

6524

do (cache-type subclass)))))

6525

(cache-type (find-class 'mime:mime-type)))

6526

cache))

6527

6528

(:documentation "extension functions"

6529

6530

"Extension operators are implemented as static native functions which a query expression designates

6531

with iri which are represented as symbols. The compiler recognizes an extension operator and generates

6532

  code to invoke it respective its context iff the iri's vocabulary is present as one of the packages in the

6533

*iri-packages* list. There are two supported contexts:

6534

  - pattern statement predicates : the bgp compiler compiles the statement match into an out-of-line call

6535

to funcall-extension

6536

- non-built-in operators : the form is compiled as a native function call, for which the standard

6537

    expansion maps solution field references into interned model terms. In this context a macro-expansion

6538

    can elect to suppress the mapping for operators which are better implemented directly in terms of term

6539

numbers.

6540

6541

The partiallibraries exist

6542

- virtuoso/gis : algebra;operators;dydra-operators

6543

- jena/ARQ operators : algebra;operators;jena-operators

6544

nb. in this case, the definitions [http://jena.sourceforge.net/ARQ/library-propfunc.html#functions]

6545

require that a logical operator serve both contexts. in once case it contributes bindings to the

6546

bgp match process and in the other it returns a boolean as a filter predicate.")

6547

6548

6549

(defgeneric extension-operator-p (object)

6550

(:documentation "Return true if the given OBJECT is a symbol in a package which is present

6551

in the *iri-packages* list.")

6552

6553

(:method ((object symbol))

6554

(when (and (find (symbol-package object) *iri-packages*)

6555

(fboundp object)

6556

(not (macro-function object)))

6557

t))

6558

(:method ((object t))

6559

nil))

6560

6561

(defgeneric funcall-extension (repository-handle context subject property-extension object continuation)

6562

(:documentation "Invoke a predicate extension operator. The base implementation is specialized for

6563

     symbol terms, to invoke the term's function on the repository, the pattern's terms - (context, subject,

6564

     property (the term itself), object) and a continuation. The function produces results by invoking the

6565

continuation on the respectively matched context, subject, property, and object.

6566

The term value domain is term numbers.

6567

     There are other implementation specific to given operators, eg. arq:member, which work differently.")

6568

6569

(:method (repository-handle context subject (property symbol) object continuation)

6570

(funcall property repository-handle context subject property object continuation)))

6571

6572

(defgeneric delegate-to-path-query (continuation transaction context subject operator object)

6573

(:argument-precedence-order operator transaction continuation context subject object)

6574

(:method ((continuation t) (transaction t) context subject (predicate property-path-verb) object)

6575

;; extract the solution generator from the operator

6576

;; if this is present in the body, bind that

6577

;; if the subject and/or predicate are bound but were present in the antecedant, bind them

6578

;; initiate the generator in its own thread

6579

;; iterate over results and pass them to the continuaton

6580

(let* ((predicate-term-number (intern-property-path predicate))

6581

(generator (property-path-verb-solution-generator predicate)))

6582

(unless generator

6583

(let ((query (property-path-verb-query predicate)))

6584

(assert (consp query) ()

6585

"Invalid path verb query: ~s" query)

6586

(let ((query-function (spocq-compile query)))

6587

(setf generator (setf (property-path-verb-solution-generator predicate)

6588

(funcall query-function))))))

6589

(let ((channel (solution-generator-channel generator)))

6590

(assert (= (length (solution-generator-dimensions generator)) 2) ()

6591

"Invalid path generator: ~s: ~s" predicate generator)

6592

(query-run-in-thread *task* generator)

6593

(do-pages (page channel)

6594

(loop for i below (page-length page)

6595

                     do (funcall continuation context (aref page i 0) predicate-term-number (aref page i 1))))))))

6596

6597

6598

;;; misc operators

6599

6600

(defgeneric state-predicate-p (predicate)

6601

(:method ((predicate (eql '|urn:dydra|:|event|)))

6602

"predicate for event bindings in collated patterns"

6603

t)

6604

(:method ((predicate t))

6605

nil))

6606

6607

(defun plist-difference (plist keys)

6608

(loop for (key value) on plist by #'cddr

6609

unless (member key keys)

6610

collect key and

6611

collect value))

6612

6613

(defun plist-merge (plist &rest args)

6614

(declare (dynamic-extent args))

6615

(loop for (key value) on args by #'cddr

6616

unless (getf key plist)

6617

do (setf plist (list* key value plist)))

6618

plist)

6619

6620

;;; (plist-difference '(:a 1 :b 2) '(:a)) (plist-difference '() '(:c))

6621

6622

6623

;;; syslog trace output

6624

6625

(defclass syslog-stream (SB-GRAY:FUNDAMENTAL-STREAM)

6626

((buffer :initform (make-array 128 :element-type 'character :fill-pointer 0 :adjustable t)

6627

:reader stream-buffer)))

6628

6629

(defmethod stream-force-output ((s syslog-stream))

6630

(let ((buffer (stream-buffer s)))

6631

(when (plusp (length buffer))

6632

(log-warn! buffer)

6633

(setf (fill-pointer buffer) 0))))

6634

6635

(defmethod stream-finish-output ((s syslog-stream))

6636

(stream-force-output s))

6637

6638

(defmethod stream-write-char ((s syslog-stream) c)

6639

(let ((buffer (stream-buffer s)))

6640

(case c

6641

(#\n (vector-push-extend #\\ buffer)

6642

(vector-push-extend #\n buffer)

6643

(stream-force-output s))

6644

(t (vector-push-extend c buffer))) buffer))

6645

6646

(defmethod stream-write-string ((s syslog-stream) line &optional (start 0) (end (length line)))

6647

(stream-force-output s)

6648

(log-warn! (subseq line start end)))

6649

6650

 (defmethod stream-write-sequence ((s syslog-stream) (string string) &optional (start 0) (end (length string)))

6651

(stream-write-string s string start end))

6652

6653

6654

(defun conditional-delete-file (pathname)

6655

"Delete the designated file if it exists."

6656

(when (and pathname (probe-file pathname))

6657

(delete-file pathname)))

6658

6659

(defgeneric resource-pathname-element (resource)

6660

(:method ((element string)) element)

6661

(:method ((element null)) nil)

6662

)

6663

6664

6665

(defun tmp-import-pathname (&rest components)

6666

(declare (dynamic-extent components))

6667

(loop with string-components = (mapcar #'resource-pathname-element components)

6668

for pathname = (make-pathname :name (format nil "import~{~@[-~a~]~}-~a"

6669

string-components

6670

(make-v1-uuid-string))

6671

:defaults (import-root-pathname))

6672

for i from 0 below 10

6673

unless (probe-file pathname)

6674

return pathname))

6675

;;; (tmp-import-pathname "asdf" "qwer")

6676

6677

(defun tmp-export-pathname (&rest components)

6678

(declare (dynamic-extent components))

6679

(loop with string-components = (mapcar #'resource-pathname-element components)

6680

for pathname = (make-pathname :name (format nil "export~{~@[-~a~]~}-~a"

6681

string-components

6682

(make-v1-uuid-string))

6683

:defaults (import-root-pathname))

6684

for i from 0 below 10

6685

unless (probe-file pathname)

6686

return pathname))

6687

6688

(defun file-hash-pathname (pathname)

6689

"return a relative pathname to identify a given file by content hash."

6690

(let* ((hash (make-sha256-digest pathname))

6691

(prefix (subseq hash 0 2)))

6692

(make-pathname :name hash :directory `(:relative ,prefix))))

6693

6694

(defgeneric mime-type-url (object &key if-does-not-exist)

6695

   (:documentation "lookup the respective url for a media type from those registered in the 'mime' package.

6696

Intended to be combined with <https://w3id.org/rdfp/mediaType> to record ldp media types.")

6697

(:method ((mime-type mime:mime-type) &rest args)

6698

(declare (dynamic-extent args))

6699

(apply #'mime-type-url (string-downcase (type-of mime-type)) args))

6700

(:method ((string string) &key (if-does-not-exist :error))

6701

(or (find-symbol string (load-time-value (find-package "mime")))

6702

(ecase if-does-not-exist

6703

((nil) nil)

6704

(:error (spocq.e:resource-not-found-error :identifier string))))))

6705

6706

(defgeneric url-mime-type (object)

6707

(:method ((non-url t))

6708

nil)

6709

(:method ((mime-type-url symbol))

6710

(when (eq (symbol-package mime-type-url) (load-time-value (find-package "mime")))

6711

(find-symbol (symbol-name mime-type-url) (load-time-value (find-package :mime)))))

6712

(:method ((mime-type-url spocq:iri))

6713

(let ((name (spocq:iri-lexical-form mime-type-url))

6714

(prefix (load-time-value (package-name (find-package "mime")))))

6715

(when (string-equal name prefix :end1 (min (length name) (length prefix)))

6716

(mime:mime-type (subseq name (length prefix)) :if-does-not-exist nil))))

6717

(:method ((string string))

6718

(find-symbol string (load-time-value (find-package "mime")))))

6719

6720

(defparameter *sparql-query-prototype* "

6721

select *

6722

from <urn:dydra:all>

6723

from named <http://example.org/rdf>

6724

where {

6725

?s ?p ?o .

6726

optional {

6727

values ?location { <http://example.com> 'http://example.com' }

6728

service ?location { ?ss ?sp ?so }

6729

filter( ?o = true )

6730

}

6731

}

6732

")

6733

6734

6735

6736

;;; mysql utilities

6737

6738

(defgeneric unescape-mysql-string (string)

6739

(:method ((string null))

6740

nil)

6741

(:method ((string string))

6742

(flet ((unescape-mysql-character (target-string start end match-start match-end reg-starts reg-ends)

6743

(declare (ignore start end match-end reg-starts reg-ends))

6744

(let ((char (char target-string (1+ match-start))))

6745

(case char

6746

(#\b #.(make-string 1 :initial-element #\backspace))

6747

(#\n #.(make-string 1 :initial-element #\newline))

6748

(#\r (make-string 1 :initial-element #\return))

6749

(#\t (make-string 1 :initial-element #\tab))

6750

(t (make-string 1 :initial-element char))))))

6751

(cl-ppcre:regex-replace-all (load-time-value (cl-ppcre:create-scanner "\\\\."))

6752

string

6753

                                                    #'unescape-mysql-character))))

6754

#|

6755

6756

6757

6758

(defmacro form-s (field bindings &environment env)

6759

`(with-dimensions ,(mapcar #'first bindings)

6760

(run-form-s ,field ',bindings)))

6761

6762

(defmacro form-p (field projection &environment env)

6763

`(with-dimensions ,projection

6764

(run-form-p ,field ',projection)))

6765

6766

(defmacro form-e (field &environment env)

6767

`(run-form-e ,field ',(declaration-information 'dimensions env)))

6768

6769

6770

(defun run-form-e (field dimensions)

6771

(list 'as-form-e field dimensions))

6772

6773

(defun run-form-p (field projection)

6774

(list 'as-form-e projection field))

6775

6776

(defun run-form-s (field bindings)

6777

(list 'as-form-s bindings field))

6778

6779

(pprint (form-s (form-p (form-e '(?::s ?::p ?::o)) (?::s ?::p)) ((?::x 1) (?::s ?::s))))

6780

6781

 (aprint (rewrite-common-bgps (query-bgps #p"P-LIBRARY:org;datagraph;spocq;src;test;rspec;tests;data-sp2b;q7.sparql")

6782

                               :factors' ((0 . bgpse-bgp-cardinality) (1 . bgpse-pattern-cardinality))))

6783

6784

(defgeneric compute-subexpression-statistics (query)

6785

(:method ((original-bgps cons))

6786

(let ((reduced-bgps (rewrite-common-bgps original-bgps))

6787

(original-patterns (reduce #'append original-bgps :key #'rest))

6788

(new-bgps ())

6789

(new-patterns ()))

6790

(dolist (bgp reduced-bgps)

6791

(push bgp new-bgps)

6792

(dolist (elt (rest bgp))

6793

(ecase (first elt)

6794

(spocq.a::|sub-bgp|

6795

(unless (member elt new-bgps :test #'equalp)

6796

(push elt new-bgps)

6797

(setf new-patterns (append (rest elt) new-patterns))))

6798

(spocq.a::|triple|

6799

(push elt new-patterns)))))

6800

(let ((original-bgp-count (length original-bgps))

6801

(new-bgp-count (length new-bgps))

6802

(original-pattern-count (length original-patterns))

6803

(new-pattern-count (length new-patterns)))

6804

         (values (if (plusp original-pattern-count) (float (/ new-pattern-count original-pattern-count) 0.0))

6805

                 (if (plusp original-bgp-count) (float (/ new-bgp-count original-bgp-count)) 0.0)

6806

new-pattern-count original-pattern-count

6807

new-bgp-count original-bgp-count))))

6808

6809

(:method ((source pathname))

6810

(if (wild-pathname-p source)

6811

(let ((original-bgp-count 0)

6812

(new-bgp-count 0)

6813

(original-pattern-count 0)

6814

(new-pattern-count 0)

6815

(query-count 0)

6816

(pat-pct-total 0)

6817

(bgp-pct-total 0))

6818

(dolist (pathname (directory source))

6819

(ignore-errors

6820

            (multiple-value-bind (pat-pct bgp-pct npc opc nbc obc) (compute-subexpression-statistics pathname)

6821

(when (< pat-pct 1)

6822

(incf query-count)

6823

(incf pat-pct-total pat-pct)

6824

(incf bgp-pct-total bgp-pct)

6825

(incf new-pattern-count npc)

6826

(incf original-pattern-count opc)

6827

(incf new-bgp-count nbc)

6828

(incf original-bgp-count obc))

6829

(format *trace-output* "~&~2$ x~d ~2$ x~d : ~s"

6830

pat-pct opc bgp-pct obc pathname))))

6831

(if (plusp query-count)

6832

(values (/ pat-pct-total query-count)

6833

(/ bgp-pct-total query-count)

6834

                   (float (/ new-pattern-count query-count)) (float (/ original-pattern-count query-count))

6835

                   (float (/ new-bgp-count query-count)) (float (/ original-bgp-count query-count)))

6836

(values 0.0 0.0 0.0 0.0)))

6837

(compute-subexpression-statistics (query-bgps source)))))

6838

6839

(compute-subexpression-statistics #p"P-LIBRARY:org;datagraph;spocq;src;test;rspec;tests;data-sp2b;q*.sparql")

6840

(compute-subexpression-statistics #p"P-LIBRARY:org;datagraph;spocq;src;test;rspec;tests;data-r2;**;*.rq")

6841

6842

(defun time-sublis (count)

6843

(let* ((uris (loop for i from 0 below 32

6844

collect (puri:uri (format nil "http://example/~a" i))))

6845

(field (loop for i from 0 below 1024

6846

for x = (mod i 32)

6847

for uri = (nth x uris)

6848

collect `(spocq.a:|triple| ,uri ,uri ,uri)))

6849

(map (loop for i from 0

6850

for uri in uris

6851

collect (cons uri i)))

6852

(total 0))

6853

(time (dotimes (x count)

6854

(incf total (length (sublis map field)))))))

6855

(time-sublis 1024)

6856

6857

6858

|#