Coverage report: /home/ati/workspace/perec/query/syntax.lisp

Kind	Covered	All	%
expression	241	386	62.4
branch	23	46	50.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;; -*- mode: Lisp; Syntax: Common-Lisp; -*-

2

;;;

3

4

;;;

5

;;; See LICENCE for details.

6

7

(in-package :cl-perec)

8

9

;;;; Syntax nodes:

10

;;;;

11

;;;; Syntax node

12

;;;; type

13

;;;;

14

;;;; Literal

15

;;;; value

16

;;;;

17

;;;; Lexical variable

18

;;;; name

19

;;;;

20

;;;; Query variable

21

;;;; name

22

;;;;

23

;;;; Slot access form

24

;;;; slot

25

;;;; arg

26

;;;;

27

;;;; Association-end access form

28

;;;; association-end

29

;;;; arg

30

;;;;

31

;;;; Function call

32

;;;; function

33

;;;; args

34

;;;;

35

;;;; Macro call

36

;;;; macro-name

37

;;;; args

38

;;;;

39

;;;; Special form

40

;;;; operator

41

;;;; args

42

43

(defmacro define-syntax-node (name (&rest supers) slots)

44

`(progn

45

;; syntax-node class

46

,(bind ((supers (append supers (list 'copyable-mixin))))

47

`(defclass* ,name ,supers

48

,slots))

49

;; make

50

,(bind ((make-fn-name (concatenate-symbol "make-" name)))

51

`(defun ,make-fn-name (&rest init-args)

52

(apply 'make-instance ',name init-args)))

53

;; copy

54

,(bind ((slot-names (mapcar #L(if (consp !1) (first !1) !1) slots)))

55

`(define-copy-method copy-inner-class progn ((self ,name) copy copy-htable)

56

(with-slot-copying (copy copy-htable self)

57

(copy-slots ,@slot-names))))

58

;; predicate

59

,(bind ((predicate-name (if (position #\- (symbol-name name))

60

(concatenate-symbol name "-p")

61

(concatenate-symbol name "p"))))

62

`(defun ,predicate-name (object)

63

(typep object ',name)))))

64

65

;;;

66

;;; Reader

67

;;;

68

(defun pattern-reader (stream subchar arg)

69

(declare (ignore subchar arg))

70

(let ((spec (read stream t nil t)))

71

(if (and (consp spec) (symbolp (first spec)))

72

(bind ((instance (allocate-instance (find-class (first spec)))))

73

(apply #'shared-initialize instance nil (rest spec)))

74

(error "wrong pattern syntax: ~A~%" spec))))

75

76

(defmacro enable-pattern-reader (&optional (dispatch-character #\M))

77

"Enable the pattern reader for the rest of the file (being loaded or compiled).

78

Be careful when using in different situations, because it modifies *readtable*."

79

;; The standard sais that *readtable* is restored after loading/compiling a file,

80

;; so we make a copy and alter that. The effect is that it will be enabled

81

;; for the rest of the file being processed.

82

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

83

(setf *readtable* (copy-readtable *readtable*))

84

(set-dispatch-macro-character #\# ,dispatch-character #'pattern-reader)))

85

86

;;;

87

;;; AST nodes

88

;;;

89

90

(defconstant +unknown-type+ :unknown)

91

92

(define-syntax-node syntax-object ()

93

((xtype +unknown-type+)))

94

95

(define-syntax-node unparsed-form (syntax-object)

96

((form)))

97

98

(define-syntax-node atomic-form (syntax-object)

99

())

100

101

(define-syntax-node literal-value (atomic-form)

102

((value)))

103

104

(define-syntax-node variable (atomic-form)

105

((name)))

106

107

(define-syntax-node lexical-variable (variable)

108

())

109

110

(define-syntax-node dynamic-variable (variable)

111

())

112

113

(define-syntax-node query-variable (variable)

114

((xtype +persistent-object-class+)))

115

116

(define-syntax-node joined-variable (query-variable)

117

((object :documentation "Object which owns the association-end.")

118

(association-end :documentation "The association-end of the object or NIL (means id).")))

119

120

(define-syntax-node compound-form (syntax-object)

121

((operator)

122

(operands)))

123

124

(define-syntax-node function-call (compound-form)

125

((operator :initarg :fn :accessor fn-of)

126

(operands :initarg :args :accessor args-of)))

127

128

(define-syntax-node slot-access (function-call)

129

((operator :initarg :accessor :accessor accessor-of)

130

(slot nil)))

131

132

(define-syntax-node association-end-access (slot-access)

133

((slot :initarg :association-end :accessor association-end-of)))

134

135

(define-syntax-node macro-call (compound-form)

136

((operator :initarg :macro :accessor macro-of)

137

(operands :initarg :args :accessor args-of)))

138

139

(define-syntax-node special-form (compound-form)

140

())

141

142

(defmethod make-load-form ((object syntax-object) &optional env)

143

(make-load-form-saving-slots

144

object

145

:slot-names (mapcar 'slot-definition-name (class-slots (class-of object)))

146

:environment env))

147

148

(defgeneric arg-of (slot-access)

149

(:method ((access slot-access))

150

(first (args-of access))))

151

152

(defgeneric (setf arg-of) (value slot-access)

153

(:method (value (access slot-access))

154

(setf (args-of access) (list value))))

155

156

(defmethod print-object ((variable variable) stream)

157

(print-unreadable-object (variable stream :type t)

158

(when (slot-boundp variable 'name)

159

(princ (name-of variable) stream))))

160

161

(defmethod print-object ((literal literal-value) stream)

162

(print-unreadable-object (literal stream :type t :identity t)

163

(when (slot-boundp literal 'value)

164

(princ (value-of literal) stream))))

165

166

167

(defmethod print-object ((form compound-form) stream)

168

(print-unreadable-object (form stream :type t)

169

(princ (if (slot-boundp form 'operator) (operator-of form) "?") stream)

170

(princ " " stream)

171

(princ (if (slot-boundp form 'operands) (operands-of form) "?") stream)))

172

173

(defun null-literal-p (syntax)

174

(and (literal-value-p syntax)

175

(null (value-of syntax))))

176

177

;;;;

178

;;;; Parse/unparse

179

;;;;

180

(defun parse-query-form (form variables)

181

(acond

182

((syntax-object-p form) form)

183

((and (symbolp form) (find form variables :key 'name-of)) it)

184

((and (atom form) (constantp form))

185

(make-literal-value :value form))

186

((and (consp form) (eq (first form) 'quote))

187

(make-literal-value :value (second form)))

188

((symbolp form)

189

(make-dynamic-variable :name form))

190

((and (symbolp (first form)) (association-end-accessor-p (first form)))

191

(make-association-end-access :accessor (first form)

192

                                  :args (list (parse-query-form (second form) variables))))

193

((and (symbolp (first form)) (slot-accessor-p (first form)))

194

(make-slot-access :accessor (first form)

195

:args (list (parse-query-form (second form) variables))))

196

((and (symbolp (first form)) (macro-function (first form)))

197

(make-macro-call :macro (first form)

198

:args (if (parse-args-p (first form))

199

                                (mapcar #L(parse-query-form !1 variables) (rest form))

200

                                (mapcar #L(make-unparsed-form :form !1) (rest form)))))

201

((and (symbolp (first form)) (special-operator-p (first form)))

202

(make-special-form :operator (first form)

203

:operands (mapcar #L(make-unparsed-form :form !1) (rest form))))

204

((and (symbolp (first form)) (fboundp (first form)))

205

(make-function-call :fn (first form)

206

:args (mapcar #L(parse-query-form !1 variables) (rest form))))

207

(t (error "Syntax error: ~S~%" form))))

208

209

(defgeneric unparse-query-syntax (syntax)

210

(:method ((unparsed unparsed-form))

211

(form-of unparsed))

212

(:method ((variable variable))

213

(name-of variable))

214

(:method ((literal literal-value))

215

(if (self-evaluating-p (value-of literal))

216

(value-of literal)

217

`(quote ,(value-of literal))))

218

(:method ((form compound-form))

219

(cons (operator-of form) (mapcar 'unparse-query-syntax (operands-of form))))

220

(:method ((pair cons)) ;; legacy

221

(rcons (unparse-query-syntax (car pair))

222

(unparse-query-syntax (cdr pair))

223

pair))

224

(:method (object) ;; legacy

225

object))

226

227

(defun self-evaluating-p (val)

228

(and (atom val)

229

(or (not (symbolp val))

230

(keywordp val)

231

(eq val t)

232

(eq val nil))))

233

234

(defun parse-args-p (macro-name)

235

(member macro-name '(and or)))

236

237

;;;;

238

;;;; Substitute

239

;;;;

240

(defgeneric substitute-syntax (syntax subs)

241

(:method ((syntax t) (subs null))

242

syntax)

243

244

(:method ((syntax t) (subs cons))

245

(aif (assoc syntax subs)

246

(cdr it)

247

syntax))

248

249

(:method ((literal literal-value) (subs cons)) ; FIXME

250

(bind ((value (substitute-syntax (value-of literal) subs)))

251

(if (eq value (value-of literal))

252

literal

253

value)))

254

255

(:method ((cons cons) (subs cons))

256

(rcons (substitute-syntax (car cons) subs)

257

(substitute-syntax (cdr cons) subs)

258

cons))

259

260

(:method ((unparsed unparsed-form) (subs cons))

261

(setf (form-of unparsed) (substitute-syntax (form-of unparsed) subs))

262

unparsed)

263

264

(:method ((compound compound-form) (subs cons))

265

(setf (operands-of compound) (substitute-syntax (operands-of compound) subs))

266

compound)

267

268

)