1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
(in-package #:monparser)
(defstruct parsing
tree
start
end)
(defstruct failure
place
(message "")
(priority 0))
(defun line-and-column (str index)
(let ((line 1) (column 1))
(dotimes (i index)
(let ((c (char str i)))
(case c
(#\Newline
(incf line)
(setf column 1))
(t (incf column)))))
(cons line column)))
(defmethod print-object ((obj failure) stream)
(if (failure-place obj)
(let ((linecol (line-and-column (data (failure-place obj))
(index (failure-place obj)))))
(format stream "~a:~a: ~a~&~a~&"
(car linecol) (cdr linecol) (failure-message obj) (failure-place obj)))
(format stream "~a~&" (failure-message obj))))
(defun fail (message &key (priority 1))
(lambda (start input)
(declare (ignore start))
(make-failure :place input :message message :priority priority)))
(defun new (tree)
(lambda (start input)
(make-parsing :tree tree :start start :end input)))
(defun bind (parser f)
(lambda (start input)
(let ((r (funcall parser input input)))
(cond ((parsing-p r)
(funcall (funcall f r) start (parsing-end r)))
((failure-p r) r)
(t (error (format nil "Invalid return value: ~a" r)))))))
(defmacro comp (bindings &body body)
(if (null bindings)
`(new (progn ,@body))
(let ((var (first (car bindings)))
(parser (second (car bindings)))
(unused (gensym)))
(cond ((symbolp var)
(if (string= (symbol-name var) "_")
`(bind ,parser
(lambda (&rest ,unused)
(declare (ignore ,unused))
(comp ,(cdr bindings) ,@body)))
`(bind ,parser
(lambda (,var &rest ,unused)
(let ((,var (parsing-tree ,var)))
(declare (ignore ,unused))
(comp ,(cdr bindings) ,@body))))))
((and (listp var) (= (length var) 1) (symbolp (car var)))
`(bind ,parser
(lambda (,(first var) &rest ,unused)
(declare (ignore ,unused))
(comp ,(cdr bindings) ,@body))))
(t (error "Binding must be either a symbol or a list of one symbol."))))))
|
