blob: 833eb41a1a74500778f4bb14b289a584ee7631b1 (
plain)
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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
|
(in-package #:monparser)
(defparameter nothing
(new nil))
(defun normalize (sym expression)
(nsubst-if sym
(lambda (x)
(and (symbolp x)
(string-equal (symbol-name x)
(symbol-name sym))))
expression))
(defmacro unit (&optional predicate)
(cond ((null predicate)
(setf predicate 't))
((symbolp predicate)
(setf predicate `(,predicate it)))
((characterp predicate)
(setf predicate `(char-equal ,predicate it)))
((listp predicate)
(if (eq (car predicate) 'function)
(setf predicate `(funcall ,predicate it))
(setf predicate
(normalize 'it predicate))))
(t (error (format nil "Invalid predicate: ~a." predicate))))
`(lambda (start input)
(declare (ignore start))
(if (has-data? input)
(let ((it (peek input)))
(if ,predicate
(make-parsing :tree it
:start input
:end (advance input))
(make-failure :place input
:message (format nil "Expected: ~a, Got: ~:c." ',predicate it))))
(make-failure :place input
:message (format nil "Reached end of input. Expected: ~a." ',predicate)))))
(defun one-of (first-parser second-parser &rest other-parsers)
(lambda (start input)
(declare (ignore start))
(let ((parsers (cons first-parser (cons second-parser other-parsers)))
(result (make-failure :place input)))
(dolist (p parsers)
(let ((r (funcall p input input)))
(cond ((parsing-p r)
(when (or (not (parsing-p result))
(> (distance (parsing-end result)
(parsing-end r))
0))
(setf result r)))
((failure-p r)
(when (failure-p result)
(let ((priority-cmp (- (failure-priority r)
(failure-priority result))))
(when (or (> priority-cmp 0)
(and (= priority-cmp 0)
(>= (distance (failure-place result)
(failure-place r))
0)))
(setf result r)))))
(t (error (format nil "Invalid return value: ~a." r))))))
result)))
(defun optional (p)
(one-of p nothing))
(defun many (p &key all)
(lambda (start input)
(declare (ignore start))
(let* ((result '()))
(do ((r (funcall p input input)
(funcall p (parsing-end r) (parsing-end r))))
((or (failure-p r)
(= (index (parsing-start r))
(index (parsing-end r))))
nil)
(push r result))
(cond ((not result)
(make-failure :place input
:message "No matches."))
((and all (has-data? (parsing-end (first result))))
(make-failure :place (parsing-end (first result))
:message "Input not exausted."))
(t (make-parsing :tree (reverse (mapcar (lambda (x) (parsing-tree x)) result))
:start input
:end (parsing-end (first result))))))))
|
