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

Kind	Covered	All	%
expression	77	223	34.5
branch	0	14	0.0

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

(:documentation "run-time implementation for the SSL machine."

6

  "This implements the internal state functions and the primitive word functions which operator on the code and

7

stack state to effect script execution.

8

9

The run-time state comprises three objects

10

- ssl::*stack* :

11

the stack of evaluated values staged for combination as function arguments

12

repreented as a list

13

- ssl:*code*

14

the sequence of expressions and words (functions) to be executed

15

represented as a list of (possibly nested) values

16

- ssl:*environment*

17

the current evaluation environment binds symbols to functions an values

18

represented as an association list

19

20

each evaluation rebinds selected state components dynamically and repeats operations from

21

   the code sequence until the sequence is exhausted, at which point the evaluation is complete and control

22

   returns to the caller. the stack then retains any any result(s). the modes execution interfaces exist

23

ssl:call : contrains the argument to be a function; calls the function without rebinding

24

ssl:evaluate : constrains the argument to be a list; rebinds just the code sequence

25

     ssl:run : accepts and rebinds all state components; given a code designator, retrieve and/or compile

26

it as required.

27

28

   in general, any object is treated as first-class, that is, permitted in code, on the stack - and as such,

29

passed and returned, as well as bound in the environment.

30

at the same time, particular object classes involve special handling

31

boolean : logical truth distinguishes not only t and nil, but 0, "", unbound variable markers and

32

empty solution fields as false (see ssl:true)

33

   word : a specialized generic function type captures the intended result arity from the definition in

34

     order to transfer the results to the run-time stack (in the ame order as if appearing in code)

35

solution-field : handled as the argument to boolean tests and to iteration control operators

36

37

the implementation resides on three levels

38

%%- operators accept values and return them

39

%- operators work the the %%- level operators to manipulate the three state objects

40

word operators again accept and returns values. the arguments are staged by the %- operators from

41

     run-time state and results are placed back into the run-time state by the invoking %- opeator uon return

42

")

43

44

45

(defclass ssl:word (sslr:function)

46

()

47

(:metaclass c2mop:funcallable-standard-class))

48

49

50

(defmacro ssl:defword (name lambda-list &rest options)

51

(macroexpand-defword name lambda-list options))

52

53

54

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

55

(defun macroexpand-defword (name lambda-list options)

56

(let* ((values-option (assoc :values options))

57

(keywords (load-time-value (cons '&code lambda-list-keywords)))

58

(after-required (member-if #'(lambda (term) (member term keywords)) lambda-list))

59

(required-parameters (ldiff lambda-list after-required))

60

(code-parameters (let* ((codes (member '&code after-required))

61

(before-codes (ldiff after-required codes))

62

                                    (after-codes (member-if #'(lambda (term) (member term keywords)) (rest codes))))

63

(when codes

64

(setf codes (ldiff codes after-codes))

65

                                 (setf lambda-list (append required-parameters (rest codes)

66

                                                           before-codes

67

                                                           after-codes))

68

(rest (ldiff codes after-codes)))))

69

(keyword-parameters (let ((keys (member '&key lambda-list)))

70

                                  (rest (ldiff keys (member-if #'(lambda (term) (member term keywords)) (rest keys))))))

71

(class-option (assoc :generic-function-class options))

72

(signature `(sslr:make-function-signature

73

:required-parameters ',required-parameters

74

:keyword-parameters ',(loop for element in keyword-parameters

75

                                                  collect (if (consp element) (caar element) (intern (symbol-name element) :keyword)))

76

:code-parameters ',code-parameters

77

:values ',(if values-option (rest values-option) '(t)))))

78

79

(setf options (remove values-option options))

80

(if class-option

81

(setf options (remove class-option options))

82

(setf class-option '(:generic-function-class ssl:word)))

83

`(let ((word (defgeneric ,name ,lambda-list ,@options ,class-option)))

84

(sslr::setf-function-signature ,signature word)

85

word)))

86

)

87

88

;;; primitives :

89

;;; stack side-effect operations :

90

;;; always reconstruct the stack rather than side-effecting it in case

91

;;; something else has a binding...

92

93

(ssl:defword ssl:bind (variable value)

94

(:documentation

95

"Introduce a binding for the pair on the stack into the current environment")

96

(:values)

97

(:method ((variable symbol) (value t))

98

(sslr:bind variable value)

99

;; discard the value

100

(values)))

101

102

(ssl:defword ssl:cons (first rest)

103

(:method ((first t) (rest t))

104

(cons first rest))

105

(:values cons))

106

107

(ssl:defword ssl:dup (top)

108

(:method ((value t))

109

(values value value))

110

(:values t t))

111

112

(ssl:defword ssl:drop (top)

113

(:method ((value t))

114

(values))

115

(:values ))

116

117

(ssl:defword ssl:first (list)

118

(:method ((value list))

119

(first value))

120

(:values t))

121

122

(ssl:defword ssl:nip (next top)

123

(:method ((next t) (top t))

124

top)

125

(:values t))

126

127

(ssl:defword ssl:rest (list)

128

(:method ((value list))

129

(rest value))

130

(:values t))

131

132

(ssl:defword ssl:set (variable value)

133

(:values )

134

(:method ((variable symbol) (value t))

135

(sslr:set variable value)

136

;; discard the value

137

(values)))

138

139

(ssl:defword ssl:swap (next top)

140

(:method ((next t) (top t))

141

(values top next))

142

(:values t t))

143

144

145

;;; environment operations :

146

147

(ssl:defword ssl:code ()

148

(:values list)

149

(:method ()

150

ssl:*code*))

151

152

(ssl:defword ssl:environment ()

153

(:values list)

154

(:method ()

155

ssl:*environment*))

156

157

158

159

(ssl:defword ssl::stack ()

160

(:values list)

161

(:method ()

162

ssl:*stack*))

163

164

165

;;; control-flow operations :

166

167

(ssl:defword ssl:call (function)

168

(:documentation "Invoke the given function, return with stack/code/environment as modified.")

169

(:values )

170

(:method ((function t))

171

(sslr:call function)))

172

173

(ssl:defword ssl:eval (object)

174

(:documentation "Evaluate the given object. Given a code list, execute it, Given anything else,

175

determine its value return with stack/environment as

176

modified, but restore the code sequence.")

177

(:values )

178

(:method ((object t))

179

(sslr:eval object)))

180

181

(ssl:defword ssl:run (code)

182

(:values )

183

(:method ((code list))

184

(sslr:run code)

185

(values)))

186

187

(ssl:defword ssl:execute (stack code environment)

188

(:documentation "Execute a stack/code/environment combination for side-effect.

189

     Invoke the internal run-time operator which restores the original stack/code/combination upon completion

190

Permit code which locates the code sequence with an iri or a local string in addition to

191

     representing the code directly as a list. Given location, load the graph under authorization constraints.")

192

(:values )

193

194

(:method (stack (code string) environment)

195

(ssl:execute stack (load-ssl-graph code) environment))

196

(:method (stack (code spocq:iri) environment)

197

(ssl:execute stack (load-ssl-graph code) environment))

198

199

(:method (stack (code list) environment)

200

(sslr:execute stack code environment)))

201

202

203

204

(ssl:defword ssl:and ()

205

(:values boolean)

206

(:method ()

207

(if sslr:*code*

208

(loop until (null sslr:*code*)

209

for result = (progn (sslr:eval (sslr:pop-code))

210

(sslr:pop))

211

while (sslr:true result)

212

finally (return result))

213

t)))

214

215

(ssl:defword ssl:if (predicate-value &code consequent alternative)

216

(:values )

217

(:method (predicate-value consequent alternative)

218

(sslr:eval (if (sslr:true predicate-value) consequent alternative))

219

(values)))

220

221

(ssl:defword ssl:not (value)

222

(:values boolean)

223

(:method (value)

224

(not (sslr:true value))))

225

226

(ssl:defword ssl:or ()

227

(:values boolean)

228

(:method ()

229

(loop until (null sslr:*code*)

230

for result = (progn (sslr:eval (sslr:pop-code))

231

(sslr:pop))

232

until (sslr:true result)

233

finally (return result))))

234

235

(ssl:defword ssl:true (value)

236

(:method ((value t))

237

(sslr:true value))

238

(:values boolean))

239

240

(ssl:defword ssl:while (&code predicate-form consequent)

241

(:values)

242

(:method (predicate-form consequent)

243

(loop while (sslr:true (progn (sslr:eval predicate-form) (sslr:pop)))

244

do (sslr:eval consequent))

245

(values)))

246

247

248

(ssl:defword ssl:continuation ()

249

(:documentation

250

"Capture the continuation as a function and push it on the stack.

251

When called, the operator will run starting from the current state and place

252

a single result on the stack upon completion.")

253

(:method ()

254

(sslr:continuation))

255

(:values function))

256

257

(ssl:defword ssl:continue (continuation)

258

(:method ((continuation function))

259

(funcall continuation))

260

(:values))

261

262

263

(ssl:defword ssl:word (code)

264

(:documentation

265

"Combine the code at the top of the stack with the current environment to construct

266

a new function and push it onto the stack")

267

(:values function)

268

(:method ((code list))

269

(sslr:closure code)))

270

271

272

(ssl:defword ssl:thread (code)

273

(:documentation "start a new thread with the tos code sequence")

274

(:method ((code list))

275

(bt:make-thread (sslr:closure code)))

276

(:values t))

277

278

279

(macrolet ((defprimitive (base-operator signature &optional (values '(t)))

280

(let ((ssl-name (intern (symbol-name base-operator) :ssl))

281

(parameters (loop for parameter in signature

282

collect (etypecase parameter

283

(symbol parameter)

284

                                                (cons (first parameter))))))

285

(export ssl-name :ssl)

286

`(ssl:defword ,ssl-name ,parameters

287

(:method ,signature

288

(,base-operator ,@parameters))

289

(:values ,values))))

290

(defprimitives (base-operators signature &optional (values '(t)))

291

`(progn ,@(loop for operator in base-operators

292

collect `(defprimitive ,operator ,signature ,values)))))

293

(defprimitives (+ - / * = < > <= >= /=) ((arg1 number) (arg2 number)))

294

(defprimitives (minusp plusp zerop not null) ((arg number)))

295

(defprimitives (decf incf) ((arg number)))

296

)

297

298

299

(ssl:defword ssl::request-stream ()

300

(:method () (processor-request-content-location *request-processor*))

301

(:values stream))

302

(ssl:defword ssl::response-stream ()

303

(:method () (processor-response-content-location *request-processor*))

304

(:values stream))

305

(ssl:defword ssl::request-content-type ()

306

(:method () (processor-request-content-type *request-processor*))

307

(:values mime:mime-type))

308

(ssl:defword ssl::response-content-type ()

309

(:method () (processor-response-content-type *request-processor*))

310

(:values mime:mime-type))

311

(ssl:defword ssl::request-repository ()

312

(:method () (task-repository *task*))

313

(:values repository))

314

315

316

;;; environment

317

318

(ssl:defword ssl::print (value)

319

(:method ((value t))

320

(print value)

321

(values ))

322

(:values))

323

324

(ssl:defword ssl::print-stack ()

325

(:method ()

326

(print ssl:*stack*)

327

(values))

328

(:values))

329

330

(ssl:defword ssl::print-code ()

331

(:method ()

332

(print ssl:*code*)

333

(values))

334

(:values))

335

336

#|

337

;;; more explicit code

338

'(("select * where { {?s ?p ?o} union { graph ?g {?s ?p ?o}} }" :location

339

mime:application/sparql-query :media-type <ssl:Decode>

340

                     "jhacker/test" :dataset <http://www.w3.org/ns/entailment/D> :method <ssl:Bind>

341

<ssl:Project>

342

mime:application/sparql-results+json :media-type

343

*trace-output* :location <ssl:Encode> )

344

<ssl:Query>)

345

|#