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

Kind	Covered	All	%
expression	32	212	15.1
branch	0	16	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

(in-package :rdfcache)

2

3

;;; Term API: Accessors

4

5

(defmacro term-slot-pointer (term-var slot-name)

6

`(foreign-slot-pointer ,term-var 'term ,slot-name))

7

8

(defmacro term-slot-value (term-var slot-name)

9

`(foreign-slot-value ,term-var 'term ,slot-name))

10

11

;; Term API

12

13

(defun make-term (term-type value &key language datatype)

14

"Returns a foreign pointer to a newly-allocated term."

15

(let ((term (%make-term term-type (null-pointer))))

16

(declare (type foreign-pointer term)

17

(type (or null keyword) term-type))

18

(setf (term-slot-value term 'value)

19

(foreign-string-alloc (string value)))

20

(when language

21

(setf (term-slot-value term 'language)

22

(foreign-string-alloc (string language))))

23

(when datatype

24

(setf (term-slot-value term 'datatype)

25

(foreign-string-alloc (string datatype))))

26

term))

27

28

(defun destroy-term (term)

29

(declare (type foreign-pointer term))

30

(unless (null-pointer-p (term-slot-value term 'datatype))

31

(foreign-string-free (term-slot-value term 'datatype))

32

(setf (term-slot-value term 'datatype) (null-pointer)))

33

(unless (null-pointer-p (term-slot-value term 'language))

34

(foreign-string-free (term-slot-value term 'language))

35

(setf (term-slot-value term 'language) (null-pointer)))

36

(unless (null-pointer-p (term-slot-value term 'value))

37

(foreign-string-free (term-slot-value term 'value))

38

(setf (term-slot-value term 'value) (null-pointer)))

39

(foreign-free term))

40

41

(defun %copy-term (%term)

42

(declare (type foreign-pointer %term))

43

(flet ((%copy-string (%string)

44

(if (null-pointer-p %string)

45

%string

46

(let* ((length (1+ (cffi::foreign-string-length %string)))

47

(%copy (foreign-alloc :char :count length)))

48

(%%memcpy %copy %string length)))))

49

(let ((%copy (%make-term (term-slot-value %term 'type) (null-pointer))))

50

(declare (type foreign-pointer %copy))

51

(setf (term-slot-value %copy 'value)

52

(%copy-string (term-slot-value %term 'value)))

53

(setf (term-slot-value %copy 'language)

54

(%copy-string (term-slot-value %term 'language)))

55

(setf (term-slot-value %copy 'datatype)

56

(%copy-string (term-slot-value %term 'datatype)))

57

%copy)))

58

59

60

(defun make-uri-term (value)

61

"Returns a foreign pointer to a newly-allocated URI term."

62

(make-term :uri value))

63

64

(defun make-node-term (value)

65

"Returns a foreign pointer to a newly-allocated blank node term."

66

(make-term :node value))

67

68

(defun make-literal-term (value &key language datatype)

69

"Returns a foreign pointer to a newly-allocated literal term."

70

(make-term :literal value :language language :datatype datatype))

71

72

(defun initialize-term (term type value &key language datatype)

73

(init-term term type value :language language :datatype datatype))

74

75

(defun init-term (term type value &key language datatype)

76

(declare (type foreign-pointer term)

77

(type keyword type)

78

(type foreign-pointer value)

79

(type (or null foreign-pointer) language datatype))

80

(with-checked-pointer (term)

81

(setf (term-slot-value term 'type) type)

82

(setf (term-slot-value term 'value) (pointer value))

83

(setf (term-slot-value term 'language)

84

(if language (pointer language) (null-pointer)))

85

(setf (term-slot-value term 'datatype)

86

(if datatype (pointer datatype) (null-pointer)))

87

term))

88

89

(defun init-uri-term (term value)

90

(declare (type foreign-pointer term value))

91

(init-term term :uri value))

92

93

(defun init-node-term (term value)

94

(declare (type foreign-pointer term value))

95

(init-term term :node value))

96

97

(defun init-literal-term (term value &key language datatype)

98

(declare (type foreign-pointer term value)

99

(type (or null foreign-pointer) language datatype))

100

(init-term term :literal value :language language :datatype datatype))

101

102

(defun term-type (term)

103

"Returns the type of the given `term` as a keyword. Possible values are

104

`:none`, `:uri`, `:node`, `:literal`, and `:id`."

105

(with-checked-pointer (term)

106

(term-slot-value term 'type)))

107

108

(defun (setf term-type) (type term)

109

(with-checked-pointer (term)

110

(setf (term-slot-value term 'type) type)))

111

112

(defun term-type-code (term)

113

"Returns the type of the given `term` as an integer. Possible values are

114

0, 1, 2, 5, and 255."

115

(foreign-enum-value 'term-type (term-type term)))

116

117

(defun term-value (term)

118

"Returns the value of the given `term` as a string."

119

(foreign-string-to-lisp (term-value-pointer term)

120

:encoding *encoding*))

121

122

(defun term-value-pointer (term)

123

"Returns a foreign string pointer to the value of the given `term`."

124

(with-checked-pointer (term)

125

(term-slot-value term 'value)))

126

127

(defun term-to-list (term)

128

"Returns the type and value of the given `term` as a two-element list."

129

(with-checked-pointer (term)

130

(let* ((type (term-type term))

131

(value (term-value term))

132

(lang-ptr (term-slot-value term 'language))

133

(dt-ptr (term-slot-value term 'datatype)))

134

(cond

135

((not (null-pointer-p lang-ptr))

136

(list type value :language (foreign-string-to-lisp lang-ptr)))

137

((not (null-pointer-p dt-ptr))

138

(list type value :datatype (foreign-string-to-lisp dt-ptr)))

139

(t

140

(list type value))))))

141

142

(defun term-to-string (term)

143

"Returns the N-Triples representation of the given `term`."

144

(serialize-term term))

145

146

;;; Term API: Macros

147

148

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

149

`(with-foreign-object (,term-var '(:struct term))

150

(setf (term-slot-value ,term-var 'type) ,type

151

(term-slot-value ,term-var 'value) ,value)

152

,@(when language

153

`((setf (term-slot-value ,term-var 'language) ,language)))

154

,@(when datatype

155

`((setf (term-slot-value ,term-var 'datatype) ,datatype)))

156

(progn ,@body)))

157

158

(defmacro with-uri-term ((term-var value) &body body)

159

`(with-term (,term-var :uri ,value) ,@body))

160

161

(defmacro with-node-term ((term-var value) &body body)

162

`(with-term (,term-var :node ,value) ,@body))

163

164

(defmacro with-literal-term ((term-var value &key language datatype) &body body)

165

`(with-term (,term-var :literal ,value

166

:language ,(or language `(null-pointer))

167

:datatype ,(or datatype `(null-pointer)))

168

,@body))

169

170

;; TODO: move to utf8.lisp

171

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

172

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

173

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

174

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

175

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

176

(type fixnum .term-value-len.)

177

(type simple-string ,string)

178

(dynamic-extent ,string))

179

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

180

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

181

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

182

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

183

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

184

(code-char .term-value-chr.)))

185

(setq .term-value-ptr.

186

(%%utf8-next-char .term-value-ptr.)))

187

,@body))

188

189

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

190

`(with-checked-pointer (,term)

191

(let* ((,term-type-var (foreign-enum-value 'term-type (term-slot-value ,term 'type)))

192

(.term-value-ptr. (term-slot-value .term-ptr. 'value))

193

(.term-language-ptr. (term-slot-value .term-ptr. 'language))

194

(.term-datatype-ptr. (term-slot-value .term-ptr. 'datatype)))

195

(rdfcache::with-term-string (,term-value-var .term-value-ptr.)

196

(cond (.term-language-ptr.

197

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

198

(let ((,term-datatype-var nil))

199

(locally ,@body))))

200

(.term-datatype-ptr.

201

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

202

(let ((,term-language-var nil))

203

(locally ,@body))))

204

(t

205

(let ((,term-language-var nil)

206

(,term-datatype-var nil))

207

(locally ,@body))))))))