From a1bddb922b84a9e00a1fe3fe4b8510323f73f3e1 Mon Sep 17 00:00:00 2001 From: Ramarren Date: Fri, 14 Jan 2011 16:08:10 +0100 Subject: [PATCH] Change uses of MDO to NAMED-SEQ?/* as appropriate. --- greedy.lisp | 78 ++++++++--------- parsers.lisp | 239 +++++++++++++++++++++++++-------------------------- 2 files changed, 158 insertions(+), 159 deletions(-) diff --git a/greedy.lisp b/greedy.lisp index 8f2b358..1ab3621 100644 --- a/greedy.lisp +++ b/greedy.lisp @@ -2,6 +2,32 @@ ;;; greedy version of repetition combinators +(defun seq-list* (&rest parsers) + "Non-backtracking parser: Return a list of result of PARSERS." + (assert parsers) + (let ((parsers (map 'vector #'ensure-parser parsers))) + (define-oneshot-result inp is-unread + (iter (for parser in-vector parsers) + (for inp-prime initially inp then (suffix-of result)) + (for result = (funcall (funcall parser inp-prime))) + (while result) + (collect result into results) + (finally (return + (when result + (make-instance 'parser-possibility + :tree (mapcar #'tree-of results) + :suffix (suffix-of result))))))))) + +(defmacro named-seq* (&rest parser-descriptions) + "Non-backtracking parser: This is similar to MDO, except that constructed parsers cannot depend on +the results of previous ones and the final form is not used as a parser, but is automatically used +to construct the result. All names bound using the (<- name parser) construct are only available in +that final form. + +This parser generator is useful when full generality of MDO is not necessary, as it is implemented +non-recursively and has better memory performance." + `(%named-seq? seq-list* ,@parser-descriptions)) + (defun between* (parser min max &optional (result-type 'list)) "Non-backtracking parser: find the first, longest chain of expression accepted by parser of length between min and max" (assert (or (null min) @@ -52,11 +78,11 @@ (defun sepby1* (parser-item parser-separator) "Non-backtracking parser: accept as many as possible of parser-item separated by parser-separator, but at least one." (with-parsers (parser-item parser-separator) - (mdo (<- x parser-item) - (<- xs (many* (mdo parser-separator - (<- y parser-item) - (result y)))) - (result (cons x xs))))) + (named-seq* (<- x parser-item) + (<- xs (many* (named-seq* parser-separator + (<- y parser-item) + y))) + (cons x xs)))) (defun sepby* (parser-item parser-separator) "Non-backtracking parser: accept as many as possible of parser-item separated by parser-separator." @@ -90,17 +116,17 @@ (defun nat* () "Non-backtracking parser: accept natural number, consuming as many digits as possible" - (chainl1* (mdo (<- x (digit?)) - (result (digit-char-p x))) + (chainl1* (named-seq* (<- x (digit?)) + (digit-char-p x)) (result #'(lambda (x y) (+ (* 10 x) y))))) (defun int* () "Non-backtracking parser: accept integer, consuming as many digits as possible" - (mdo (<- f (choice1 (mdo (char? #\-) (result #'-)) (result #'identity))) - (<- n (nat*)) - (result (funcall f n)))) + (named-seq* (<- f (choice1 (mdo (char? #\-) (result #'-)) (result #'identity))) + (<- n (nat*)) + (funcall f n))) (defun chainr1* (p op) "Non-backtracking parser: accept as many as possible, but at least one of p, reduced by result of op with right associativity" @@ -283,38 +309,12 @@ (:left (chainl1* base op)) (:right (chainr1* base op)) (:unary (choice1 - (mdo (<- op-fun op) - (<- subexpr base) - (result (funcall op-fun subexpr))) + (named-seq* (<- op-fun op) + (<- subexpr base) + (funcall op-fun subexpr)) base)))) (finally (return base))))) (when (and bracket-left bracket-right) (setf wrapped-term (choice1 (bracket? bracket-left expr-parser bracket-right) term))) expr-parser))))) - -(defun seq-list* (&rest parsers) - "Non-backtracking parser: Return a list of result of PARSERS." - (assert parsers) - (let ((parsers (map 'vector #'ensure-parser parsers))) - (define-oneshot-result inp is-unread - (iter (for parser in-vector parsers) - (for inp-prime initially inp then (suffix-of result)) - (for result = (funcall (funcall parser inp-prime))) - (while result) - (collect result into results) - (finally (return - (when result - (make-instance 'parser-possibility - :tree (mapcar #'tree-of results) - :suffix (suffix-of result))))))))) - -(defmacro named-seq* (&rest parser-descriptions) - "Non-backtracking parser: This is similar to MDO, except that constructed parsers cannot depend on -the results of previous ones and the final form is not used as a parser, but is automatically used -to construct the result. All names bound using the (<- name parser) construct are only available in -that final form. - -This parser generator is useful when full generality of MDO is not necessary, as it is implemented -non-recursively and has better memory performance." - `(%named-seq? seq-list* ,@parser-descriptions)) diff --git a/parsers.lisp b/parsers.lisp index 56cb479..458ec3e 100644 --- a/parsers.lisp +++ b/parsers.lisp @@ -1,5 +1,90 @@ (in-package :parser-combinators) +(defun seq-list? (&rest parsers) + "Parser: Return a list of results of PARSERS." + (assert parsers) + (let ((parsers (map 'vector #'ensure-parser parsers))) + #'(lambda (inp) + (let ((continuation-stack (list (funcall (aref parsers 0) inp))) + (result-stack nil) + (continuation-count 1) + (result-count 0) + (l (length parsers))) + #'(lambda () + (iter (while continuation-stack) + (until (= result-count l)) + (let ((next-result (funcall (car continuation-stack)))) + (cond ((null next-result) + (pop continuation-stack) + (decf continuation-count) + (pop result-stack) + (decf result-count)) + ((= continuation-count l) + (incf result-count) + (push next-result result-stack)) + (t + (incf result-count) + (push next-result result-stack) + (incf continuation-count) + (push (funcall (aref parsers result-count) + (suffix-of next-result)) + continuation-stack)))) + (finally + (return + (when result-stack + (let ((result + (make-instance 'parser-possibility + :tree (mapcar #'tree-of (reverse result-stack)) + :suffix (suffix-of (car result-stack))))) + (decf result-count) + (pop result-stack) + result)))))))))) + +(defmacro %named-seq? (sequence-parser &rest parser-descriptions) + (assert (> (length parser-descriptions) 1)) + (let ((name-vector (make-array (1- (length parser-descriptions)) :initial-element nil)) + (parsers nil) + (result-form nil) + (gensym-list nil)) + (iter (for description in parser-descriptions) + (for i from 0) + (cond ((= i (length name-vector)) + (setf result-form description)) + ((and (listp description) + (eql (car description) '<-)) + (setf (aref name-vector i) (second description)) + (push (third description) parsers)) + (t + (push description parsers) + (let ((gensym (gensym))) + (push gensym gensym-list) + (setf (aref name-vector i) gensym))))) + (with-unique-names (inp continuation seq-parser result) + `(let ((,seq-parser (,sequence-parser ,@(nreverse parsers)))) + #'(lambda (,inp) + (let ((,continuation (funcall ,seq-parser ,inp))) + #'(lambda () + (when ,continuation + (let ((,result (funcall ,continuation))) + (if ,result + (destructuring-bind ,(map 'list #'identity name-vector) + (tree-of ,result) + ,@(when gensym-list + (list `(declare (ignore ,@gensym-list)))) + (make-instance 'parser-possibility + :tree ,result-form + :suffix (suffix-of ,result))) + (setf ,continuation nil))))))))))) + +(defmacro named-seq? (&rest parser-descriptions) + "Parser: This is similar to MDO, except that constructed parsers cannot depend on the results of +previous ones and the final form is not used as a parser, but is automatically used to construct the +result. All names bound using the (<- name parser) construct are only available in that final form. + +This parser generator is useful when full generality of MDO is not necessary, as it is implemented +non-recursively and has better memory performance." + `(%named-seq? seq-list? ,@parser-descriptions)) + (defparameter *cut-tag* nil) (defun tag? (parser format-control &rest format-arguments) @@ -151,14 +236,14 @@ parsers." (defun sepby1? (parser-item parser-separator) "Parser: accept at least one of parser-item separated by parser-separator" (with-parsers (parser-item parser-separator) - (mdo (<- x parser-item) - (<- xs (many? (mdo parser-separator (<- y parser-item) (result y)))) - (result (cons x xs))))) + (named-seq? (<- x parser-item) + (<- xs (many? (mdo parser-separator (<- y parser-item) (result y)))) + (cons x xs)))) (defun bracket? (parser-open parser-center parser-close) "Parser: accept parser-center bracketed by parser-open and parser-close" (with-parsers (parser-open parser-center parser-close) - (mdo parser-open (<- xs parser-center) parser-close (result xs)))) + (named-seq? parser-open (<- xs parser-center) parser-close xs))) (defun sepby? (parser-item parser-separator) "Parser: accept zero or more of parser-item separated by parser-separator" @@ -171,9 +256,9 @@ parsers." (defun sepby1-cons? (p op) "Parser: as sepby1, but returns a list of a result of p and pairs (op p). Mainly a component parser for chains" (with-parsers (p op) - (let ((between-parser (between? (mdo (<- op-result op) - (<- p-result p) - (result (cons op-result p-result))) + (let ((between-parser (between? (named-seq? (<- op-result op) + (<- p-result p) + (cons op-result p-result)) 1 nil))) #'(lambda (inp) (let ((front-continuation (funcall p inp)) @@ -213,30 +298,28 @@ parsers." "Parser: accept one or more p reduced by result of op with left associativity" (with-parsers (p op) (let ((subparser (sepby1-cons? p op))) - (mdo (<- chain subparser) - (result - (destructuring-bind (front . chain) chain - (iter (for left initially front - then (funcall op - left - right)) - (for (op . right) in chain) - (finally (return left))))))))) + (named-seq? (<- chain subparser) + (destructuring-bind (front . chain) chain + (iter (for left initially front + then (funcall op + left + right)) + (for (op . right) in chain) + (finally (return left)))))))) (defun chainr1? (p op) "Parser: accept one or more p reduced by result of op with right associativity" (with-parsers (p op) (let ((subparser (sepby1-cons? p op))) - (mdo (<- chain subparser) - (result - (destructuring-bind (front . chain) chain - (iter (with chain = (reverse chain)) - (with current-op = (car (car chain))) - (with current-right = (cdr (car chain))) - (for (op . right) in (cdr chain)) - (setf current-right (funcall current-op right current-right) - current-op op) - (finally (return (funcall op front current-right)))))))))) + (named-seq? (<- chain subparser) + (destructuring-bind (front . chain) chain + (iter (with chain = (reverse chain)) + (with current-op = (car (car chain))) + (with current-right = (cdr (car chain))) + (for (op . right) in (cdr chain)) + (setf current-right (funcall current-op right current-right) + current-op op) + (finally (return (funcall op front current-right))))))))) (defun chainl? (p op v) "Parser: like chainl1?, but will return v if no p can be parsed" @@ -303,8 +386,9 @@ parsers." (defun find-after? (p q) "Parser: Find q after some sequence of p, earliest matches first." (with-parsers (p q) - (mdo (breadth? p nil nil nil) - q))) + (named-seq? (breadth? p nil nil nil) + (<- result q) + result))) (defun find-before? (p q &optional (result-type 'list)) "Parser: Find a sequence of p terminated by q, doesn't consume q." @@ -323,11 +407,11 @@ parsers." result)))))) (defun find-after-collect? (p q &optional (result-type 'list)) - "Parser: Find first q after some sequence of p. Return cons of list of p-results and q" + "Parser: Find q after some sequence of p, earliest match first. Return cons of list of p-results and q" (with-parsers (p q) - (mdo (<- prefix (breadth? p nil nil result-type)) - (<- q-result q) - (result (cons prefix q-result))))) + (named-seq? (<- prefix (breadth? p nil nil result-type)) + (<- q-result q) + (cons prefix q-result)))) (defun find? (q) "Parser: Find q, earliest match first." @@ -349,97 +433,12 @@ parsers." (:left (chainl1? base op)) (:right (chainr1? base op)) (:unary (choice - (mdo (<- op-fun op) - (<- subexpr base) - (result (funcall op-fun subexpr))) + (named-seq? (<- op-fun op) + (<- subexpr base) + (funcall op-fun subexpr)) base)))) (finally (return base))))) (when (and bracket-left bracket-right) (setf wrapped-term (choice (bracket? bracket-left expr-parser bracket-right) term))) expr-parser))))) - -(defun seq-list? (&rest parsers) - "Parser: Return a list of results of PARSERS." - (assert parsers) - (let ((parsers (map 'vector #'ensure-parser parsers))) - #'(lambda (inp) - (let ((continuation-stack (list (funcall (aref parsers 0) inp))) - (result-stack nil) - (continuation-count 1) - (result-count 0) - (l (length parsers))) - #'(lambda () - (iter (while continuation-stack) - (until (= result-count l)) - (let ((next-result (funcall (car continuation-stack)))) - (cond ((null next-result) - (pop continuation-stack) - (decf continuation-count) - (pop result-stack) - (decf result-count)) - ((= continuation-count l) - (incf result-count) - (push next-result result-stack)) - (t - (incf result-count) - (push next-result result-stack) - (incf continuation-count) - (push (funcall (aref parsers result-count) - (suffix-of next-result)) - continuation-stack)))) - (finally - (return - (when result-stack - (let ((result - (make-instance 'parser-possibility - :tree (mapcar #'tree-of (reverse result-stack)) - :suffix (suffix-of (car result-stack))))) - (decf result-count) - (pop result-stack) - result)))))))))) - -(defmacro %named-seq? (sequence-parser &rest parser-descriptions) - (assert (> (length parser-descriptions) 1)) - (let ((name-vector (make-array (1- (length parser-descriptions)) :initial-element nil)) - (parsers nil) - (result-form nil) - (gensym-list nil)) - (iter (for description in parser-descriptions) - (for i from 0) - (cond ((= i (length name-vector)) - (setf result-form description)) - ((and (listp description) - (eql (car description) '<-)) - (setf (aref name-vector i) (second description)) - (push (third description) parsers)) - (t - (push description parsers) - (let ((gensym (gensym))) - (push gensym gensym-list) - (setf (aref name-vector i) gensym))))) - (with-unique-names (inp continuation seq-parser result) - `(let ((,seq-parser (,sequence-parser ,@(nreverse parsers)))) - #'(lambda (,inp) - (let ((,continuation (funcall ,seq-parser ,inp))) - #'(lambda () - (when ,continuation - (let ((,result (funcall ,continuation))) - (if ,result - (destructuring-bind ,(map 'list #'identity name-vector) - (tree-of ,result) - ,@(when gensym-list - (list `(declare (ignore ,@gensym-list)))) - (make-instance 'parser-possibility - :tree ,result-form - :suffix (suffix-of ,result))) - (setf ,continuation nil))))))))))) - -(defmacro named-seq? (&rest parser-descriptions) - "Parser: This is similar to MDO, except that constructed parsers cannot depend on the results of -previous ones and the final form is not used as a parser, but is automatically used to construct the -result. All names bound using the (<- name parser) construct are only available in that final form. - -This parser generator is useful when full generality of MDO is not necessary, as it is implemented -non-recursively and has better memory performance." - `(%named-seq? seq-list? ,@parser-descriptions))