Coverage report: /home/ati/workspace/perec/util/pattern-matcher.lisp

Kind	Covered	All	%
expression	317	448	70.8
branch	73	86	84.9

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

;;;;;;;;;;;;;;;;;;;;;;;

10

;;; Binding environment

11

12

(defconstant failed-match nil)

13

14

(defconstant no-bindings (if (boundp 'no-bindings)

15

(symbol-value 'no-bindings)

16

'((t . t))))

17

18

(defun match-variable (var input bindings)

19

"Does VAR match input? Uses (or updates) and returns bindings."

20

(let ((binding (get-binding var bindings)))

21

(cond ((not binding) (extend-bindings var input bindings))

22

((equal input (binding-val binding)) bindings)

23

(t failed-match))))

24

25

(defun make-binding (var val) (cons var val))

26

27

(defun binding-var (binding)

28

"Get the variable part of a single binding."

29

(car binding))

30

31

(defun binding-val (binding)

32

"Get the value part of a single binding."

33

(cdr binding))

34

35

(defun get-binding (var bindings)

36

"Find a (variable . value) pair in a binding list."

37

(assoc var bindings))

38

39

(defun lookup (var bindings)

40

"Get the value part (for var) from a binding list."

41

(binding-val (get-binding var bindings)))

42

43

(defun extend-bindings (var val bindings)

44

"Add a (var . value) pair to a binding list."

45

(cons (cons var val)

46

;; Once we add a "real" binding,

47

;; we can get rid of the dummy no-bindings

48

(if (equal bindings no-bindings)

49

nil

50

bindings)))

51

52

(defun pattern-variable-p (x)

53

"Is x a variable (a symbol beginning with `?')?"

54

(and (symbolp x) (equal (elt (symbol-name x) 0) #\?)))

55

56

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

57

;;; Matcher (PAIPROLOG matcher + objects)

58

59

(defun pattern-match (pattern input &optional (bindings no-bindings))

60

"Match pattern against input in the context of the bindings"

61

(cond ((eq bindings failed-match) failed-match)

62

((pattern-variable-p pattern)

63

(match-variable pattern input bindings))

64

((eql pattern input) bindings)

65

((segment-pattern-p pattern)

66

(segment-matcher pattern input bindings))

67

((single-pattern-p pattern) ; ***

68

(single-matcher pattern input bindings)) ; ***

69

((object-pattern-p pattern)

70

(object-matcher pattern input bindings))

71

((and (consp pattern) (consp input))

72

(pattern-match (rest pattern) (rest input)

73

(pattern-match (first pattern) (first input)

74

bindings)))

75

(t failed-match)))

76

77

(defmacro pattern-case (expr &body clauses)

78

(with-unique-names (expr-var)

79

`(bind ((,expr-var ,expr))

80

(acond

81

,@(mapcar

82

(lambda (clause)

83

(bind ((pattern-vars (collect-pattern-variables (car clause))))

84

`((pattern-match ',(car clause) ,expr-var)

85

(let ,(mapcar #L(`(,!1 (binding-val (get-binding ',!1 it)))) pattern-vars)

86

(declare (ignorable ,@pattern-vars))

87

,@(cdr clause)))))

88

clauses)))))

89

90

(defun collect-pattern-variables (syntax &optional found-so-far)

91

"Return a list of leaves of tree satisfying predicate,

92

with duplicates removed."

93

(labels ((recurse ()

94

(typecase syntax

95

(standard-object

96

(collect-slots (mapcar 'slot-definition-name (class-slots (class-of syntax)))))

97

(cons

98

(collect-pattern-variables

99

(car syntax)

100

(collect-pattern-variables (cdr syntax) found-so-far)))

101

(otherwise

102

found-so-far)))

103

(collect-slots (slots)

104

(cond

105

((null slots) found-so-far)

106

((slot-boundp syntax (first slots))

107

(collect-pattern-variables (slot-value syntax (first slots))

108

(collect-slots (rest slots))))

109

(t (collect-slots (rest slots))))))

110

(if (pattern-variable-p syntax)

111

(adjoin syntax found-so-far)

112

(recurse))))

113

114

(setf (get '?is 'single-match) 'match-is)

115

(setf (get '?or 'single-match) 'match-or)

116

(setf (get '?and 'single-match) 'match-and)

117

(setf (get '?not 'single-match) 'match-not)

118

(setf (get '?* 'segment-match) 'segment-match)

119

(setf (get '?+ 'segment-match) 'segment-match+)

120

(setf (get '?? 'segment-match) 'segment-match?)

121

(setf (get '?if 'segment-match) 'match-if)

122

123

(defun single-pattern-p (pattern)

124

"Is this a single-matching pattern?

125

E.g. (?is x predicate) (?and . patterns) (?or . patterns)."

126

(and (consp pattern)

127

(single-match-fn (first pattern))))

128

129

(defun single-matcher (pattern input bindings)

130

"Call the right function for this kind of single pattern."

131

(funcall (single-match-fn (first pattern))

132

(rest pattern) input bindings))

133

134

(defun single-match-fn (x)

135

"Get the single-match function for x,

136

if it is a symbol that has one."

137

(when (symbolp x) (get x 'single-match)))

138

139

(defun segment-matcher (pattern input bindings)

140

"Call the right function for this kind of segment pattern."

141

(funcall (segment-match-fn (first (first pattern)))

142

pattern input bindings))

143

144

(defun segment-pattern-p (pattern)

145

"Is this a segment-matching pattern like ((?* var) . pat)?"

146

(and (consp pattern) (consp (first pattern))

147

(symbolp (first (first pattern)))

148

(segment-match-fn (first (first pattern)))))

149

150

(defun segment-match-fn (x)

151

"Get the segment-match function for x,

152

if it is a symbol that has one."

153

(when (symbolp x) (get x 'segment-match)))

154

155

(defun segment-match (pattern input bindings &optional (start 0))

156

"Match the segment pattern ((?* var) . pat) against input."

157

(let ((var (second (first pattern)))

158

(pat (rest pattern)))

159

(if (null pat)

160

(match-variable var input bindings)

161

(let ((pos (first-match-pos (first pat) input start)))

162

(if (null pos)

163

failed-match

164

(let ((b2 (pattern-match

165

pat (subseq input pos)

166

(match-variable var (subseq input 0 pos)

167

bindings))))

168

;; If this match failed, try another longer one

169

(if (eq b2 failed-match)

170

(segment-match pattern input bindings (+ pos 1))

171

b2)))))))

172

173

(defun first-match-pos (pat1 input start)

174

"Find the first position that pat1 could possibly match input,

175

starting at position start. If pat1 is non-constant, then just

176

return start."

177

(cond ((and (atom pat1) (not (pattern-variable-p pat1)))

178

(position pat1 input :start start :test #'equal))

179

((<= start (length input)) start) ;*** fix, rjf 10/1/92 (was <)

180

(t nil)))

181

182

(defun segment-match+ (pattern input bindings)

183

"Match one or more elements of input."

184

(segment-match pattern input bindings 1))

185

186

(defun segment-match? (pattern input bindings)

187

"Match zero or one element of input."

188

(let ((var (second (first pattern)))

189

(pat (rest pattern)))

190

(or (pattern-match (cons var pat) input bindings)

191

(pattern-match pat input bindings))))

192

193

(defun object-pattern-p (pattern)

194

(typep pattern 'standard-object))

195

196

(defun object-matcher (pattern input bindings)

197

(labels ((slot-matcher (slots bindings)

198

(cond

199

((eq bindings failed-match) failed-match)

200

((null slots) bindings)

201

((and (slot-boundp pattern (first slots))

202

(slot-boundp input (first slots)))

203

(slot-matcher (rest slots)

204

(pattern-match (slot-value pattern (first slots))

205

                                              (slot-value input (first slots))

206

bindings)))

207

((slot-boundp pattern (first slots)) failed-match)

208

(t (slot-matcher (rest slots) bindings)))))

209

(if (or (eq bindings failed-match) (not (typep input (class-of pattern))))

210

failed-match

211

(bind ((slots (mapcar 'slot-definition-name (class-slots (class-of pattern)))))

212

(slot-matcher slots bindings)))))

213

214

(defun match-if (pattern input bindings)

215

"Test an arbitrary expression involving variables.

216

The pattern looks like ((?if code) . rest)."

217

;; *** fix, rjf 10/1/92 (used to eval binding values)

218

(and (progv (mapcar #'car bindings)

219

(mapcar #'cdr bindings)

220

(eval `(locally (declare (special ,@(mapcar #'car bindings)))

221

,(second (first pattern)))))

222

(pattern-match (rest pattern) input bindings)))

223

224

(defun match-is (var-and-pred input bindings)

225

"Succeed and bind var if the input satisfies pred,

226

where var-and-pred is the list (var pred)."

227

(let* ((var (first var-and-pred))

228

(pred (second var-and-pred))

229

(new-bindings (pattern-match var input bindings)))

230

(if (or (eq new-bindings failed-match)

231

(not (funcall pred input)))

232

failed-match

233

new-bindings)))

234

235

(defun match-and (patterns input bindings)

236

"Succeed if all the patterns match the input."

237

(cond ((eq bindings failed-match) failed-match)

238

((null patterns) bindings)

239

(t (match-and (rest patterns) input

240

(pattern-match (first patterns) input

241

bindings)))))

242

243

(defun match-or (patterns input bindings)

244

"Succeed if any one of the patterns match the input."

245

(if (null patterns)

246

failed-match

247

(let ((new-bindings (pattern-match (first patterns)

248

input bindings)))

249

(if (eq new-bindings failed-match)

250

(match-or (rest patterns) input bindings)

251

new-bindings))))

252

253

(defun match-not (patterns input bindings)

254

"Succeed if none of the patterns match the input.

255

This will never bind any variables."

256

(if (match-or patterns input bindings)

257

failed-match

258

bindings))