From f134bb2f244ea9719f671f21fb6d1d7b5aee1df5 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Thu, 25 Apr 2013 11:53:42 +0400 Subject: [PATCH 01/95] Smart context sensitivity, first try. --- esrap.asd | 2 +- esrap.lisp | 200 +++++++++++++++++++--------- example-very-context-sensitive.lisp | 63 +++++++++ 3 files changed, 198 insertions(+), 67 deletions(-) create mode 100644 example-very-context-sensitive.lisp diff --git a/esrap.asd b/esrap.asd index 6745ecc..8f68708 100644 --- a/esrap.asd +++ b/esrap.asd @@ -25,7 +25,7 @@ :version "0.9" :description "A Packrat / Parsing Grammar / TDPL parser for Common Lisp." :licence "MIT" - :depends-on (:alexandria) + :depends-on (:alexandria :defmacro-enhance :iterate) :components ((:file "esrap") (:static-file "example-sexp.lisp") (:static-file "example-symbol-table.lisp") diff --git a/esrap.lisp b/esrap.lisp index 614d130..8f65075 100644 --- a/esrap.lisp +++ b/esrap.lisp @@ -30,14 +30,14 @@ ;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (defpackage :esrap - (:use :cl :alexandria) + (:use :cl :alexandria :defmacro-enhance :iterate) #+sbcl (:lock t) (:export #:&bounds #:! #:? #:+ #:* #:& #:~ - #:character-ranges + #:character-ranges #:wrap #:add-rule #:call-transform @@ -533,7 +533,7 @@ are allowed only if JUNK-ALLOWED is true." position (simple-esrap-error text position "Incomplete parse."))))))) -(defmacro defrule (&whole form symbol expression &body options) +(defmacro! defrule (&whole form symbol expression &body options) "Define SYMBOL as a nonterminal, using EXPRESSION as associated the parsing expression. Following OPTIONS can be specified: @@ -664,7 +664,13 @@ Following OPTIONS can be specified: (function transform)) (flet ((call-transform () (funcall transform))) - ,@forms))))))))) + ,@forms))))) + ((:wrap-around &body forms) + (setf around `(lambda (,e!-wrapper ,e!-parser) ; should change to g!-syms here + (declare (ignorable ,e!-wrapper ,e!-parser)) + (flet ((,e!-call-parser () + (funcall ,e!-parser))) + ,@forms)))))))) `(eval-when (:load-toplevel :execute) (add-rule ',symbol (make-instance 'rule :expression ',expression @@ -683,11 +689,14 @@ associated with a rule, the old rule is removed first." (error "~S is already associated with the nonterminal ~S -- remove it first." rule (rule-symbol rule))) (let* ((cell (ensure-rule-cell symbol)) - (function (compile-rule symbol + (function (compile-rule symbol (rule-expression rule) (rule-condition rule) (rule-transform rule) (rule-around rule))) + (function (lambda (text position end) + (format t "parsing ~a ~a~%" symbol position) + (funcall function text position end))) (trace-info (cell-trace-info cell))) (set-cell-info cell function rule) (setf (cell-trace-info cell) nil) @@ -860,58 +869,112 @@ inspection." (defun compile-rule (symbol expression condition transform around) (declare (type (or boolean function) condition transform around)) - (let* ((*current-rule* symbol) - ;; Must bind *CURRENT-RULE* before compiling the expression! - (function (compile-expression expression)) - (rule-not-active (when condition (make-inactive-rule :name symbol)))) - (cond ((not condition) - (named-lambda inactive-rule (text position end) - (declare (ignore text position end)) - rule-not-active)) - (transform - (flet ((exec-rule/transform (text position end) - (let ((result (funcall function text position end))) - (if (error-result-p result) - (make-failed-parse - :expression symbol - :position (if (failed-parse-p result) - (failed-parse-position result) - position) - :detail result) - (if around - (make-result - :position (result-position result) - :production (flet ((call-rule () - (funcall transform - (result-production result) - position - (result-position result)))) - (funcall around position (result-position result) #'call-rule))) - (make-result - :position (result-position result) - :production (funcall transform - (result-production result) - position - (result-position result)))))))) - (if (eq t condition) - (named-lambda rule/transform (text position end) - (with-cached-result (symbol position text) - (exec-rule/transform text position end))) - (named-lambda condition-rule/transform (text position end) - (with-cached-result (symbol position text) - (if (funcall condition) - (exec-rule/transform text position end) - rule-not-active)))))) - (t - (if (eq t condition) - (named-lambda rule (text position end) - (with-cached-result (symbol position text) - (funcall function text position end))) - (named-lambda conditional-rule (text position end) - (with-cached-result (symbol position text) - (if (funcall condition) - (funcall function text position end) - rule-not-active)))))))) + (let ((*current-rule* symbol)) + ;; Must bind *CURRENT-RULE* before compiling the expression! + (if (and (consp expression) + (symbolp (car expression)) + (equal (string (car expression)) "WRAP")) + (destructuring-bind (wrap wrapper wrappie) expression + (declare (ignore wrap)) + (format t "Imhere!~%") + (let* ((func-wrapper (compile-expression wrapper)) + (rule-not-active (when condition (make-inactive-rule :name symbol)))) + (cond ((not condition) + (named-lambda inactive-rule (text position end) + (declare (ignore text position end)) + rule-not-active)) + ((not (and transform around)) + (error "When specifying WRAP rule both TRANSFORM and AROUND should be present.")) + (t (flet ((exec-rule/transform (text position end) + (let ((wrapper-result (funcall func-wrapper text position end))) + (if (error-result-p wrapper-result) + (make-failed-parse + :expression symbol + :position (if (failed-parse-p wrapper-result) + (failed-parse-position wrapper-result) + position) + :detail wrapper-result) + (funcall around + (result-production wrapper-result) + (lambda () + (let* ((func-wrappie (compile-expression wrappie)) + (wrappie-result (funcall func-wrappie text + (result-position wrapper-result) + end))) + (if (error-result-p wrappie-result) + (make-failed-parse + :expression symbol + :position (if (failed-parse-p wrappie-result) + (failed-parse-position wrappie-result) + position) + :detail wrappie-result) + (let ((production (funcall transform + (result-production wrappie-result) + position + (result-position wrappie-result)))) + (make-result + :position (result-position wrappie-result) + :production (values production))))))))))) + (if (eq t condition) + (named-lambda rule/transform (text position end) + (with-cached-result (symbol position text) + (exec-rule/transform text position end))) + (named-lambda condition-rule/transform (text position end) + (with-cached-result (symbol position text) + (if (funcall condition) + (exec-rule/transform text position end) + rule-not-active))))))))) + (let* ((function (compile-expression expression)) + (rule-not-active (when condition (make-inactive-rule :name symbol)))) + (format t "Im there!~%") + (cond ((not condition) + (named-lambda inactive-rule (text position end) + (declare (ignore text position end)) + rule-not-active)) + (transform + (flet ((exec-rule/transform (text position end) + (let ((result (funcall function text position end))) + (if (error-result-p result) + (make-failed-parse + :expression symbol + :position (if (failed-parse-p result) + (failed-parse-position result) + position) + :detail result) + (if around + (make-result + :position (result-position result) + :production (flet ((call-rule () + (funcall transform + (result-production result) + position + (result-position result)))) + (funcall around position (result-position result) #'call-rule))) + (make-result + :position (result-position result) + :production (funcall transform + (result-production result) + position + (result-position result)))))))) + (if (eq t condition) + (named-lambda rule/transform (text position end) + (with-cached-result (symbol position text) + (exec-rule/transform text position end))) + (named-lambda condition-rule/transform (text position end) + (with-cached-result (symbol position text) + (if (funcall condition) + (exec-rule/transform text position end) + rule-not-active)))))) + (t + (if (eq t condition) + (named-lambda rule (text position end) + (with-cached-result (symbol position text) + (funcall function text position end))) + (named-lambda conditional-rule (text position end) + (with-cached-result (symbol position text) + (if (funcall condition) + (funcall function text position end) + rule-not-active)))))))))) ;;; EXPRESSION COMPILER & EVALUATOR @@ -938,7 +1001,8 @@ inspection." t) (cons (case (car expression) - ((and or) + ((and or wrap) + ;; (format t "Imhere!") (and (every #'validate-expression (cdr expression)) t)) ((nil) nil) @@ -1336,10 +1400,12 @@ inspection." (let ((function (compile-expression subexpr))) (named-lambda compiled-greedy-repetition (text position end) (let ((results - (loop for result = (funcall function text position end) - until (error-result-p result) - do (setf position (result-position result)) - collect result))) + (iter (for result next (funcall function text position end)) + (until (or (error-result-p result) + (if-first-time nil + (equal (result-position result) position)))) + (setf position (result-position result)) + (collect result)))) (make-result :position position :production (mapcar #'result-production results))))))) @@ -1356,10 +1422,12 @@ inspection." (named-lambda compiled-greedy-positive-repetition (text position end) (let* ((last nil) (results - (loop for result = (funcall function text position end) - until (error-result-p (setf last result)) - do (setf position (result-position result)) - collect result))) + (iter (for result next (funcall function text position end)) + (until (or (error-result-p (setf last result)) + (if-first-time nil + (equal (result-position result) position)))) + (setf position (result-position result)) + (collect result)))) (if results (make-result :position position diff --git a/example-very-context-sensitive.lisp b/example-very-context-sensitive.lisp new file mode 100644 index 0000000..1e58bbb --- /dev/null +++ b/example-very-context-sensitive.lisp @@ -0,0 +1,63 @@ +;;;; Esrap example: grammar, in which context is determined by a natural number + +(require :esrap) + +(defpackage :very-context-sensitive + (:use :cl :esrap)) + +(in-package :very-context-sensitive) + +(defparameter indent 0 "Indent that is stripped from all lines.") + +(defrule spaces (* #\space) + (:lambda (lst) + (length lst))) + +(defun indented-p (len) + (>= len indent)) + +(defrule indented-spaces (indented-p spaces) + (:lambda (len) + (- len indent))) + +(defrule digit (character-ranges (#\0 #\9))) + +(defrule indent-spec-line (and spaces "|" (+ digit) "|" spaces #\newline) + (:destructure (wh0 ch0 digits ch1 wh1 nl0) + (declare (ignore wh0 ch0 ch1 wh1 nl0)) + (parse-integer (text digits)))) + +(defrule indented-line (and indented-spaces (* (not #\newline)) #\newline) + (:destructure (isps line nl0) + (declare (ignore nl0)) + (text (make-string isps :initial-element #\space) + line))) + +(defrule explicit-indented-block (wrap indent-spec-line + (* (and (! indent-spec-line) + indented-line))) + (:wrap-around (let ((indent wrapper)) + (call-parser))) + (:lambda (lst) + (mapcar #'cadr lst))) + +(defrule explicit-blocks (+ explicit-indented-block)) + +(defrule implicit-indented-block (wrap "" + (* (and (! indent-spec-line) + indented-line))) + (:wrap-around (let ((indent 0)) + (call-parser))) + (:lambda (lst) + (mapcar #'cadr lst))) + +(defrule implicit-blocks (+ implicit-indented-block)) + +(defrule indented-block (or explicit-indented-block + implicit-indented-block)) + +(defrule blocks (+ indented-block)) + +(defrule multi-spaces (+ spaces)) + + From 4000583833cde4ac6ece0206dbd1a036a8770007 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Thu, 25 Apr 2013 17:58:10 +0400 Subject: [PATCH 02/95] Basic dynamic wrapping done, tests written. --- esrap.asd | 2 +- esrap.lisp | 216 +++++++++++++++------------- example-very-context-sensitive.lisp | 40 ++++-- tests.lisp | 43 +++++- 4 files changed, 181 insertions(+), 120 deletions(-) diff --git a/esrap.asd b/esrap.asd index 8f68708..26b7afd 100644 --- a/esrap.asd +++ b/esrap.asd @@ -25,7 +25,7 @@ :version "0.9" :description "A Packrat / Parsing Grammar / TDPL parser for Common Lisp." :licence "MIT" - :depends-on (:alexandria :defmacro-enhance :iterate) + :depends-on (:alexandria :defmacro-enhance :iterate :rutils) :components ((:file "esrap") (:static-file "example-sexp.lisp") (:static-file "example-symbol-table.lisp") diff --git a/esrap.lisp b/esrap.lisp index 8f65075..279879d 100644 --- a/esrap.lisp +++ b/esrap.lisp @@ -31,6 +31,7 @@ (defpackage :esrap (:use :cl :alexandria :defmacro-enhance :iterate) + (:shadowing-import-from :rutils.string :strcat) #+sbcl (:lock t) (:export @@ -406,6 +407,10 @@ symbols." (defvar *nonterminal-stack* nil) +(defun hash->assoc (hash) + (iter (for (key val) in-hashtable hash) + (collect `(,key . ,val)))) + ;;; SYMBOL, POSITION, and CACHE must all be lexical variables! (defmacro with-cached-result ((symbol position &optional (text nil)) &body forms) (with-gensyms (cache result) @@ -598,6 +603,37 @@ Following OPTIONS can be specified: This option can be used to safely track nesting depth, manage symbol tables or for other stack-like operations. + * (:WRAP-AROUND &BODY BODY) + + Another way to perform stack-like operations. + Shadows everything, that's specified in the :AROUND clause. + If used, it is assumed, that EXPRESSION is of the form (LIST 'WRAP WRAPPER WRAPPIE), + where WRAPPER and WRAPPIE are arbitrary expressions, not containing WRAP. + All this being the case, parsing of a rule proceeds as follows: + * first, WRAPPER is parsed. + * if that succeeds, BODY is executed, with WRAPPER bound to result of parsing + WRAPPER, and PARSER bound to thunk to parse WRAPPIE. + Additionally, CALL-PARSER is synonym to (FUNCALL PARSER), + just to mimick CALL-TRANSFORM of original :AROUND clause. + + Typical use-case would be: + + (defrule my-wrapping-rule (wrap wrapper wrappie) + (:wrap-around (let ((context-var-1 (car wrapper)) ; set dynamic state based on WRAPPER + (context-var-2 (cadr wrapper))) + (call-parser))) ; trigger further parsing + (:lambda (lst) ; LST here is result of parsing WRAPPIE + (list :context `(,context-var-1 ,context-var-2) ; yep, we are inside the context + :content lst))) ; designated by the wrapper. + + If that sounds a little bit confusing, see test-suite DYNAMIC-WRAPPING + in TESTS.LISP and EXAMPLE-VERY-CONTEXT-SENSITIVE.LISP for examples. + This feature was introduced to express rules for reading block-scalars in YaML, + hence, see www.yaml.org for the specification of block scalars and the idea of why + this feature is needed. + + Since no parsing of a WRAPPIE is occured at the time BODY is executed, nothing sensible + can be bound to &BOUNDS. " (let ((transform nil) (around nil) @@ -695,7 +731,6 @@ associated with a rule, the old rule is removed first." (rule-transform rule) (rule-around rule))) (function (lambda (text position end) - (format t "parsing ~a ~a~%" symbol position) (funcall function text position end))) (trace-info (cell-trace-info cell))) (set-cell-info cell function rule) @@ -869,112 +904,88 @@ inspection." (defun compile-rule (symbol expression condition transform around) (declare (type (or boolean function) condition transform around)) - (let ((*current-rule* symbol)) - ;; Must bind *CURRENT-RULE* before compiling the expression! - (if (and (consp expression) - (symbolp (car expression)) - (equal (string (car expression)) "WRAP")) - (destructuring-bind (wrap wrapper wrappie) expression - (declare (ignore wrap)) - (format t "Imhere!~%") - (let* ((func-wrapper (compile-expression wrapper)) + (macrolet ((cur-parse-failed (&optional (result-var 'result)) + `(make-failed-parse + :expression symbol + :position (if (failed-parse-p ,result-var) + (failed-parse-position ,result-var) + position) + :detail ,result-var)) + (call-transform (&optional (result-var 'result)) + `(funcall transform + (result-production ,result-var) + position + (result-position ,result-var))) + (conditionally-exec (name &body body) + `(if (eq t condition) + (named-lambda ,name (text position end) + (with-cached-result (symbol position text) + ,@body)) + (named-lambda ,(intern (strcat "CONDITIONAL-" name)) (text position end) + (with-cached-result (symbol position text) + (if (funcall condition) + (progn ,@body) + rule-not-active))))) + (make-result-evenly (result-var &optional (production '(call-transform))) + `(make-result :position (result-position ,result-var) + :production ,production))) + (let ((*current-rule* symbol)) + ;; Must bind *CURRENT-RULE* before compiling the expression! + (if (and (consp expression) + (symbolp (car expression)) + (equal (string (car expression)) "WRAP")) + (destructuring-bind (wrap wrapper wrappie) expression + (declare (ignore wrap)) + (let* ((func-wrapper (compile-expression wrapper)) + (rule-not-active (when condition (make-inactive-rule :name symbol)))) + (cond ((not condition) + (named-lambda inactive-rule (text position end) + (declare (ignore text position end)) + rule-not-active)) + ((not (and transform around)) + (error "When specifying WRAP rule both TRANSFORM and AROUND should be present.")) + (t (flet ((exec-rule/wrap (text position end) + (let ((wrapper-result (funcall func-wrapper text position end))) + (if (error-result-p wrapper-result) + (cur-parse-failed wrapper-result) + (funcall around + (result-production wrapper-result) + (lambda () + (let* ((func-wrappie (compile-expression wrappie)) + (wrappie-result (funcall func-wrappie text + (result-position wrapper-result) + end))) + (if (error-result-p wrappie-result) + (cur-parse-failed wrappie-result) + (let ((production (call-transform wrappie-result))) + (make-result-evenly wrappie-result + (values production))))))))))) + (conditionally-exec rule/wrap + (exec-rule/wrap text position end))))))) + (let* ((function (compile-expression expression)) (rule-not-active (when condition (make-inactive-rule :name symbol)))) (cond ((not condition) (named-lambda inactive-rule (text position end) (declare (ignore text position end)) rule-not-active)) - ((not (and transform around)) - (error "When specifying WRAP rule both TRANSFORM and AROUND should be present.")) - (t (flet ((exec-rule/transform (text position end) - (let ((wrapper-result (funcall func-wrapper text position end))) - (if (error-result-p wrapper-result) - (make-failed-parse - :expression symbol - :position (if (failed-parse-p wrapper-result) - (failed-parse-position wrapper-result) - position) - :detail wrapper-result) - (funcall around - (result-production wrapper-result) - (lambda () - (let* ((func-wrappie (compile-expression wrappie)) - (wrappie-result (funcall func-wrappie text - (result-position wrapper-result) - end))) - (if (error-result-p wrappie-result) - (make-failed-parse - :expression symbol - :position (if (failed-parse-p wrappie-result) - (failed-parse-position wrappie-result) - position) - :detail wrappie-result) - (let ((production (funcall transform - (result-production wrappie-result) - position - (result-position wrappie-result)))) - (make-result - :position (result-position wrappie-result) - :production (values production))))))))))) - (if (eq t condition) - (named-lambda rule/transform (text position end) - (with-cached-result (symbol position text) - (exec-rule/transform text position end))) - (named-lambda condition-rule/transform (text position end) - (with-cached-result (symbol position text) - (if (funcall condition) - (exec-rule/transform text position end) - rule-not-active))))))))) - (let* ((function (compile-expression expression)) - (rule-not-active (when condition (make-inactive-rule :name symbol)))) - (format t "Im there!~%") - (cond ((not condition) - (named-lambda inactive-rule (text position end) - (declare (ignore text position end)) - rule-not-active)) - (transform - (flet ((exec-rule/transform (text position end) - (let ((result (funcall function text position end))) - (if (error-result-p result) - (make-failed-parse - :expression symbol - :position (if (failed-parse-p result) - (failed-parse-position result) - position) - :detail result) - (if around - (make-result - :position (result-position result) - :production (flet ((call-rule () - (funcall transform - (result-production result) - position - (result-position result)))) - (funcall around position (result-position result) #'call-rule))) - (make-result - :position (result-position result) - :production (funcall transform - (result-production result) - position - (result-position result)))))))) - (if (eq t condition) - (named-lambda rule/transform (text position end) - (with-cached-result (symbol position text) - (exec-rule/transform text position end))) - (named-lambda condition-rule/transform (text position end) - (with-cached-result (symbol position text) - (if (funcall condition) - (exec-rule/transform text position end) - rule-not-active)))))) - (t - (if (eq t condition) - (named-lambda rule (text position end) - (with-cached-result (symbol position text) - (funcall function text position end))) - (named-lambda conditional-rule (text position end) - (with-cached-result (symbol position text) - (if (funcall condition) - (funcall function text position end) - rule-not-active)))))))))) + (transform + (flet ((exec-rule/transform (text position end) + (let ((result (funcall function text position end))) + (if (error-result-p result) + (cur-parse-failed) + (if around + (make-result-evenly result + (flet ((call-rule () + (call-transform))) + (funcall around + position + (result-position result) + #'call-rule))) + (make-result-evenly result)))))) + (conditionally-exec rule/transform + (exec-rule/transform text position end)))) + (t (conditionally-exec rule + (funcall function text position end))))))))) ;;; EXPRESSION COMPILER & EVALUATOR @@ -1002,7 +1013,6 @@ inspection." (cons (case (car expression) ((and or wrap) - ;; (format t "Imhere!") (and (every #'validate-expression (cdr expression)) t)) ((nil) nil) diff --git a/example-very-context-sensitive.lisp b/example-very-context-sensitive.lisp index 1e58bbb..c2b2888 100644 --- a/example-very-context-sensitive.lisp +++ b/example-very-context-sensitive.lisp @@ -33,31 +33,41 @@ (text (make-string isps :initial-element #\space) line))) +(defun more-indented-block-p (explicit-block) + (>= (caddr explicit-block) + indent)) + (defrule explicit-indented-block (wrap indent-spec-line - (* (and (! indent-spec-line) - indented-line))) + (* (or (more-indented-block-p explicit-indented-block) + (and (! indent-spec-line) + indented-line)))) (:wrap-around (let ((indent wrapper)) (call-parser))) (:lambda (lst) - (mapcar #'cadr lst))) + `(expl-block :indent ,indent + :contents ,(mapcar (lambda (x) + (case (car x) + (expl-block x) + (t (cadr x)))) + lst)))) (defrule explicit-blocks (+ explicit-indented-block)) -(defrule implicit-indented-block (wrap "" - (* (and (! indent-spec-line) - indented-line))) - (:wrap-around (let ((indent 0)) - (call-parser))) - (:lambda (lst) - (mapcar #'cadr lst))) +;; (defrule implicit-indented-block (wrap "" +;; (* (and (! indent-spec-line) +;; indented-line))) +;; (:wrap-around (let ((indent 0)) +;; (call-parser))) +;; (:lambda (lst) +;; (mapcar #'cadr lst))) -(defrule implicit-blocks (+ implicit-indented-block)) +;; (defrule implicit-blocks (+ implicit-indented-block)) -(defrule indented-block (or explicit-indented-block - implicit-indented-block)) +;; (defrule indented-block (or implicit-indented-block +;; explicit-indented-block)) -(defrule blocks (+ indented-block)) +;; (defrule blocks (* indented-block)) -(defrule multi-spaces (+ spaces)) +;; (defrule multi-spaces (+ spaces)) diff --git a/tests.lisp b/tests.lisp index 9a70d7e..eb6c509 100644 --- a/tests.lisp +++ b/tests.lisp @@ -269,7 +269,7 @@ (multiple-value-list (parse '(or "foo" "bar") "foo")))) (is (eq 'foo+ (add-rule 'foo+ (make-instance 'rule :expression '(+ "foo"))))) - (is (equal '("foo" "foo" "foo") + (is (equal '(("foo" "foo" "foo") nil) (multiple-value-list (parse 'foo+ "foofoofoo")))) (is (eq 'decimal (add-rule 'decimal @@ -283,6 +283,47 @@ (is (equal '(nil 0) (multiple-value-list (parse '(evenp decimal) "123" :junk-allowed t))))) +;; Testing ambiguity when repetitioning possibly empty-string-match + +(defrule spaces (* #\space) + (:lambda (lst) + (length lst))) + +(defrule greedy-pos-spaces (+ spaces)) +(defrule greedy-spaces (* spaces)) + +(test ambiguous-greedy-repetitions + (is (equal '((3) nil) (multiple-value-list (parse 'greedy-spaces " ")))) + (is (equal '((3) nil) (multiple-value-list (parse 'greedy-pos-spaces " "))))) + +(defparameter separator #\space) + +(defrule simple-prefix (character-ranges (#\a #\z))) + +(defun separator-p (x) + (and (characterp x) (char= x separator))) + +(defrule separator (separator-p character)) + +(defrule word (+ (not separator)) + (:text t)) + +(defrule simple-wrapped (wrap simple-prefix + (and word + (* (and separator word)) + (? separator))) + (:wrap-around (let ((separator wrapper)) + (call-parser))) + (:destructure (word rest-words sep) + (declare (ignore sep)) + `(,word ,@(mapcar #'cadr rest-words)))) + +(test dynamic-wrapping + (is (equal '(("oo" "oo" "oo") nil) + (multiple-value-list (parse 'simple-wrapped "foofoofoof")))) + (is (equal '(("oofoofoof") nil) + (multiple-value-list (parse 'simple-wrapped "goofoofoof"))))) + (defun run-tests () (let ((results (run 'esrap))) (eos:explain! results) From 97282fa27228a9da1c1bcce6be1f57e53efeeb50 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Fri, 26 Apr 2013 02:46:12 +0400 Subject: [PATCH 03/95] Added {m,n} repetitions, a la that are present in regexps, but M and N can be resolved on dynamics --- README | 9 +++++++-- esrap.lisp | 45 +++++++++++++++++++++++++++++++++++++++------ tests.lisp | 13 +++++++++++++ 3 files changed, 59 insertions(+), 8 deletions(-) diff --git a/README b/README index 4d78a6d..ed40d82 100644 --- a/README +++ b/README @@ -49,15 +49,20 @@ Syntax overview: (character-ranges ranges) -- character ranges (and &rest sequence) (or &rest ordered-choices) - (* greedy-repetition) + (* [[from] to] greedy-repetition) (+ greedy-positive-repetition) (? optional) (& followed-by) -- does not consume (! not-followed-by) -- does not consume ( expr) -- semantic parsing + FROM and TO in (* ...) form may be arbitrary forms (e.g. special variables), but use with caution - + feature is experimental and probably does not handle local environment correctly. + See file example-sexp.lisp for a complete sample grammar and usage, - and example-symbol-table.lisp for a grammar with lexical scope. + example-symbol-table.lisp for a grammar with lexical scope, + example-very-context-sensitive.lisp for more complex example of context-sensitive grammar, + and tests.lisp for various rather trivial use-cases. Trivial examples: diff --git a/esrap.lisp b/esrap.lisp index 279879d..c009f8c 100644 --- a/esrap.lisp +++ b/esrap.lisp @@ -1021,6 +1021,8 @@ inspection." (typep (second expression) 'array-length))) (character-ranges (and (every #'validate-character-range (cdr expression)) t)) + (* (and (>= (length expression) 2) + (validate-expression (car (last expression))))) (t (and (symbolp (car expression)) (cdr expression) (not (cddr expression)) @@ -1095,8 +1097,8 @@ inspection." (eval-ordered-choise expression text position end)) (not (eval-negation expression text position end)) - (* - (eval-greedy-repetition expression text position end)) + (* (cond ((equal (length expression) 2) (eval-greedy-repetition expression)) + (t (eval-times expression)))) (+ (eval-greedy-positive-repetition expression text position end)) (? @@ -1109,7 +1111,7 @@ inspection." (eval-character-ranges expression text position end)) (t (if (symbolp (car expression)) - (eval-semantic-predicate expression text position end) + (eval-semantic-predicate expression text position end) (invalid-expression-error expression))))) (t (invalid-expression-error expression)))) @@ -1134,8 +1136,8 @@ inspection." (compile-ordered-choise expression)) (not (compile-negation expression)) - (* - (compile-greedy-repetition expression)) + (* (cond ((equal (length expression) 2) (compile-greedy-repetition expression)) + (t (compile-times expression)))) (+ (compile-greedy-positive-repetition expression)) (? @@ -1148,7 +1150,7 @@ inspection." (compile-character-ranges expression)) (t (if (symbolp (car expression)) - (compile-semantic-predicate expression) + (compile-semantic-predicate expression) (invalid-expression-error expression))))) (t (invalid-expression-error expression)))) @@ -1377,6 +1379,8 @@ inspection." ;;; Negations + + (defun exec-negation (fun expr text position end) (if (and (< position end) (error-result-p (funcall fun text position end))) @@ -1420,6 +1424,35 @@ inspection." :position position :production (mapcar #'result-production results))))))) +(defun eval-times (expression text position end) + (funcall (compile-times expression) text position end)) + +(defun compile-times (expression) + (destructuring-bind (from to subexpr) + (if (equal (length expression) 3) + `(0 ,@(cdr expression)) + (cdr expression)) + (eval `(let ((function (compile-expression ',subexpr))) + (named-lambda compiled-times (text position end) + (let* ((last nil) + (results + (iter (for i from 1 to ,to) + (for result next (funcall function text position end)) + (until (or (error-result-p (setf last result)) + (if-first-time nil + (equal (result-position result) position)))) + (setf position (result-position result)) + (collect result)))) + (if (>= (length results) ,from) + (make-result + :position position + :production (mapcar #'result-production results)) + (make-failed-parse + :position position + :expression ',expression + :detail last)))))))) + + ;;; Greedy positive repetitions (defun eval-greedy-positive-repetition (expression text position end) diff --git a/tests.lisp b/tests.lisp index eb6c509..cedf6ec 100644 --- a/tests.lisp +++ b/tests.lisp @@ -324,6 +324,19 @@ (is (equal '(("oofoofoof") nil) (multiple-value-list (parse 'simple-wrapped "goofoofoof"))))) +(defparameter dyna-from 3) +(defparameter dyna-to 5) + +(defrule dyna-from-to (* dyna-from dyna-to "a") + (:text t)) + +(defrule dyna-from-tos (* dyna-from-to)) + +(test dynamic-times + (is (equal '("aaaaa" "aaa") (parse 'dyna-from-tos "aaaaaaaa"))) + (is (equal '("aaaa" "aaaa") (let ((dyna-to 4)) + (parse 'dyna-from-tos "aaaaaaaa"))))) + (defun run-tests () (let ((results (run 'esrap))) (eos:explain! results) From f357196e8cada08af153b4a4b0df69dc541bf3ad Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Fri, 26 Apr 2013 15:25:14 +0400 Subject: [PATCH 04/95] choise -> choice + added cond operator with tests --- esrap.lisp | 91 ++++++++++++++++++++++++++++++++++++++++++++---------- tests.lisp | 17 ++++++++++ 2 files changed, 91 insertions(+), 17 deletions(-) diff --git a/esrap.lisp b/esrap.lisp index c009f8c..a9ade7a 100644 --- a/esrap.lisp +++ b/esrap.lisp @@ -1023,6 +1023,10 @@ inspection." (and (every #'validate-character-range (cdr expression)) t)) (* (and (>= (length expression) 2) (validate-expression (car (last expression))))) + (cond (and (every (lambda (x) + (and (every #'validate-expression x) t)) + (cdr expression)) + t)) (t (and (symbolp (car expression)) (cdr expression) (not (cddr expression)) @@ -1094,7 +1098,7 @@ inspection." (and (eval-sequence expression text position end)) (or - (eval-ordered-choise expression text position end)) + (eval-ordered-choice expression text position end)) (not (eval-negation expression text position end)) (* (cond ((equal (length expression) 2) (eval-greedy-repetition expression)) @@ -1109,6 +1113,8 @@ inspection." (eval-not-followed-by expression text position end)) (character-ranges (eval-character-ranges expression text position end)) + (cond + (eval-cond expression text position end)) (t (if (symbolp (car expression)) (eval-semantic-predicate expression text position end) @@ -1133,7 +1139,7 @@ inspection." (and (compile-sequence expression)) (or - (compile-ordered-choise expression)) + (compile-ordered-choice expression)) (not (compile-negation expression)) (* (cond ((equal (length expression) 2) (compile-greedy-repetition expression)) @@ -1148,6 +1154,8 @@ inspection." (compile-not-followed-by expression)) (character-ranges (compile-character-ranges expression)) + (cond + (compile-cond expression)) (t (if (symbolp (car expression)) (compile-semantic-predicate expression) @@ -1271,9 +1279,9 @@ inspection." (setf position (result-position result))) (push result results)))))))) -;;; Ordered choises +;;; Ordered choices -(defun eval-ordered-choise (expression text position end) +(defun eval-ordered-choice (expression text position end) (with-expression (expression (or &rest subexprs)) (let (last-error) (dolist (expr subexprs @@ -1296,7 +1304,7 @@ inspection." (setf last-error result)) (return result))))))) -(defun compile-ordered-choise (expression) +(defun compile-ordered-choice (expression) (with-expression (expression (or &rest subexprs)) (let ((type :characters) (canonized nil)) @@ -1327,10 +1335,10 @@ inspection." (ecase type (:characters ;; If every subexpression is a length 1 string, we can represent the whole - ;; choise with a single string. - (let ((choises (apply #'concatenate 'string canonized))) - (named-lambda compiled-character-choise (text position end) - (let ((c (and (< position end) (find (char text position) choises)))) + ;; choice with a single string. + (let ((choices (apply #'concatenate 'string canonized))) + (named-lambda compiled-character-choice (text position end) + (let ((c (and (< position end) (find (char text position) choices)))) (if c (make-result :position (+ 1 position) :production (string c)) @@ -1338,23 +1346,23 @@ inspection." :expression expression :position position)))))) (:strings - ;; If every subexpression is a string, we can represent the whole choise + ;; If every subexpression is a string, we can represent the whole choice ;; with a list of strings. - (let ((choises (nreverse canonized))) - (named-lambda compiled-character-choise (text position end) - (dolist (choise choises + (let ((choices (nreverse canonized))) + (named-lambda compiled-character-choice (text position end) + (dolist (choice choices (make-failed-parse :expression expression :position position)) - (let ((len (length choise))) - (when (match-terminal-p choise len text position end t) + (let ((len (length choice))) + (when (match-terminal-p choice len text position end t) (return (make-result :position (+ len position) - :production choise)))))))) + :production choice)))))))) (:general ;; In the general case, compile subexpressions and call. (let ((functions (mapcar #'compile-expression subexprs))) - (named-lambda compiled-ordered-choise (text position end) + (named-lambda compiled-ordered-choice (text position end) (let (last-error) (dolist (fun functions (make-failed-parse @@ -1621,6 +1629,55 @@ inspection." (named-lambda compiled-character-ranges (text position end) (exec-character-ranges expression ranges text position end)))) +(defun eval-cond (expression text position end) + (funcall (compile-cond expression) + text position end)) + +(defun compile-cond (expression) + (with-expression (expression (cond &rest subexprs)) + (let ((functions (iter (for subexp in subexprs) + (collect `(,(if (and (symbolp (car subexp)) + (or (eql (car subexp) 't) + (eql (car subexp) 'otherwise))) + (lambda (text start end) + (declare (ignore text end)) + (make-result :position start + :production (lambda () t))) + (compile-expression (car subexp))) + ,(compile-expression (cadr subexp))))))) + (named-lambda compiled-cond (text position end) + (let (pred-result result last-error) + (macrolet ((mark-result-as-last-error (&optional (result-var 'result)) + `(when (or (and (not last-error) + (or (inactive-rule-p ,result-var) + (< position (failed-parse-position ,result-var)))) + (and last-error + (failed-parse-p ,result-var) + (or (inactive-rule-p last-error) + (< (failed-parse-position last-error) + (failed-parse-position ,result-var))))) + (setf last-error ,result-var)))) + (iter (for (predicate value-function) in functions) + (setf pred-result (funcall predicate text position end)) + (if (error-result-p pred-result) + (mark-result-as-last-error pred-result) + (progn (setf result (funcall value-function text + (result-position pred-result) end)) + (if (error-result-p result) + (mark-result-as-last-error) + (terminate)))) + (finally (return (if (and result (not (error-result-p result))) + result + (make-failed-parse + :expression expression + :position (if (and last-error + (failed-parse-p last-error)) + (failed-parse-position last-error) + position) + :detail last-error))))))))))) + + + (defvar *indentation-hint-table* nil) (defun hint-slime-indentation () diff --git a/tests.lisp b/tests.lisp index cedf6ec..e7f60b4 100644 --- a/tests.lisp +++ b/tests.lisp @@ -337,6 +337,23 @@ (is (equal '("aaaa" "aaaa") (let ((dyna-to 4)) (parse 'dyna-from-tos "aaaaaaaa"))))) +(defrule cond-word (cond (dyna-from-to word))) + +(defparameter context nil) +(defun in-context-p (x) + (declare (ignore x)) + context) +(defrule context (in-context-p "")) +(defrule ooc-word word + (:constant "out of context word")) +(test cond + (is (equal "foo" (parse 'cond-word "aaaafoo"))) + (is (equal "foo" (let ((context t)) (parse '(cond (context word)) "foo")))) + (is (equal :error-occured (handler-case (parse '(cond (context word)) "foo") + (error () :error-occured)))) + (is (equal "out of context word" (parse '(cond (context word) (t ooc-word)) + "foo")))) + (defun run-tests () (let ((results (run 'esrap))) (eos:explain! results) From 9d3a45268e85d10bca0c71c3ec700e4f175f2c87 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Sun, 28 Apr 2013 21:17:01 +0400 Subject: [PATCH 05/95] Comment compiler macro as it does not work as intended. --- esrap.lisp | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/esrap.lisp b/esrap.lisp index a9ade7a..1a767e8 100644 --- a/esrap.lisp +++ b/esrap.lisp @@ -494,24 +494,24 @@ are allowed only if JUNK-ALLOWED is true." end junk-allowed))) -(define-compiler-macro parse (&whole form expression &rest arguments - &environment env) - (if (constantp expression env) - (with-gensyms (expr-fun) - `(let ((,expr-fun (load-time-value (compile-expression ,expression)))) - ;; This inline-lambda here provides keyword defaults and - ;; parsing, so the compiler-macro doesn't have to worry - ;; about evaluation order. - ((lambda (text &key (start 0) end junk-allowed) - (let ((*cache* (make-cache)) - (end (or end (length text)))) - (process-parse-result - (funcall ,expr-fun text start end) - text - end - junk-allowed))) - ,@arguments))) - form)) +;; (define-compiler-macro parse (&whole form expression &rest arguments +;; &environment env) +;; (if (constantp expression env) +;; (with-gensyms (expr-fun) +;; `(let ((,expr-fun (load-time-value (compile-expression ,expression)))) +;; ;; This inline-lambda here provides keyword defaults and +;; ;; parsing, so the compiler-macro doesn't have to worry +;; ;; about evaluation order. +;; ((lambda (text &key (start 0) end junk-allowed) +;; (let ((*cache* (make-cache)) +;; (end (or end (length text)))) +;; (process-parse-result +;; (funcall ,expr-fun text start end) +;; text +;; end +;; junk-allowed))) +;; ,@arguments))) +;; form)) (defun process-parse-result (result text end junk-allowed) (if (error-result-p result) From 833aaa1e58e2d8296681f6a07fa2b230f5873717 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Sun, 28 Apr 2013 21:44:41 +0400 Subject: [PATCH 06/95] Take context into account when memoising results. --- esrap.lisp | 47 +++++++++++++++++++++++++++-------------------- tests.lisp | 1 - 2 files changed, 27 insertions(+), 21 deletions(-) diff --git a/esrap.lisp b/esrap.lisp index a9ade7a..57e4774 100644 --- a/esrap.lisp +++ b/esrap.lisp @@ -37,6 +37,7 @@ (:export #:&bounds + #:context #:! #:? #:+ #:* #:& #:~ #:character-ranges #:wrap @@ -68,6 +69,8 @@ ;;; Conditions +(defun foo () nil) + (define-condition esrap-error (parse-error) ((text :initarg :text :initform nil :reader esrap-error-text) (position :initarg :position :initform nil :reader esrap-error-position)) @@ -394,16 +397,20 @@ symbols." ;;; For now we just use EQUAL hash-tables, but a specialized ;;; representation would probably pay off. +(defparameter context :void "Context, which is active, when the rule is trying to parse. +Cache depends not only on rule-name and position, but also on the context assumed while +parsing.") + (defvar *cache*) (defun make-cache () (make-hash-table :test #'equal)) (defun get-cached (symbol position cache) - (gethash (cons symbol position) cache)) + (gethash (list symbol position context) cache)) (defun (setf get-cached) (result symbol position cache) - (setf (gethash (cons symbol position) cache) result)) + (setf (gethash (list symbol position context) cache) result)) (defvar *nonterminal-stack* nil) @@ -494,24 +501,24 @@ are allowed only if JUNK-ALLOWED is true." end junk-allowed))) -(define-compiler-macro parse (&whole form expression &rest arguments - &environment env) - (if (constantp expression env) - (with-gensyms (expr-fun) - `(let ((,expr-fun (load-time-value (compile-expression ,expression)))) - ;; This inline-lambda here provides keyword defaults and - ;; parsing, so the compiler-macro doesn't have to worry - ;; about evaluation order. - ((lambda (text &key (start 0) end junk-allowed) - (let ((*cache* (make-cache)) - (end (or end (length text)))) - (process-parse-result - (funcall ,expr-fun text start end) - text - end - junk-allowed))) - ,@arguments))) - form)) +;; (define-compiler-macro parse (&whole form expression &rest arguments +;; &environment env) +;; (if (constantp expression env) +;; (with-gensyms (expr-fun) +;; `(let ((,expr-fun (load-time-value (compile-expression ,expression)))) +;; ;; This inline-lambda here provides keyword defaults and +;; ;; parsing, so the compiler-macro doesn't have to worry +;; ;; about evaluation order. +;; ((lambda (text &key (start 0) end junk-allowed) +;; (let ((*cache* (make-cache)) +;; (end (or end (length text)))) +;; (process-parse-result +;; (funcall ,expr-fun text start end) +;; text +;; end +;; junk-allowed))) +;; ,@arguments))) +;; form)) (defun process-parse-result (result text end junk-allowed) (if (error-result-p result) diff --git a/tests.lisp b/tests.lisp index e7f60b4..435700c 100644 --- a/tests.lisp +++ b/tests.lisp @@ -339,7 +339,6 @@ (defrule cond-word (cond (dyna-from-to word))) -(defparameter context nil) (defun in-context-p (x) (declare (ignore x)) context) From a2892f31d4cc9a1ca3583d4ba9c8ae76840187c6 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Sun, 28 Apr 2013 23:02:14 +0400 Subject: [PATCH 07/95] Add followed-by-not-gen and preceded-by-not-gen operators --- README | 2 ++ esrap.lisp | 67 +++++++++++++++++++++++++++++++++++++++++++++++++++--- tests.lisp | 8 ++++++- 3 files changed, 73 insertions(+), 4 deletions(-) diff --git a/README b/README index ed40d82..b59381a 100644 --- a/README +++ b/README @@ -53,6 +53,8 @@ Syntax overview: (+ greedy-positive-repetition) (? optional) (& followed-by) -- does not consume + (-> followed-by-not-gen) -- does not consume, produces NIL + (<- preceded-by-not-gen) -- succeeds, if preceeded by something of length 1, produces NIL (! not-followed-by) -- does not consume ( expr) -- semantic parsing diff --git a/esrap.lisp b/esrap.lisp index 57e4774..5cff0a8 100644 --- a/esrap.lisp +++ b/esrap.lisp @@ -38,7 +38,7 @@ #:&bounds #:context - #:! #:? #:+ #:* #:& #:~ + #:! #:? #:+ #:* #:& #:~ #:<- #:-> #:character-ranges #:wrap #:add-rule @@ -1108,14 +1108,18 @@ inspection." (eval-ordered-choice expression text position end)) (not (eval-negation expression text position end)) - (* (cond ((equal (length expression) 2) (eval-greedy-repetition expression)) - (t (eval-times expression)))) + (* (cond ((equal (length expression) 2) (eval-greedy-repetition expression text position end)) + (t (eval-times expression text position end)))) (+ (eval-greedy-positive-repetition expression text position end)) (? (eval-optional expression text position end)) (& (eval-followed-by expression text position end)) + (-> + (eval-followed-by-not-gen expression text position end)) + (<- + (eval-preceded-by-not-gen expression text position end)) (! (eval-not-followed-by expression text position end)) (character-ranges @@ -1157,6 +1161,10 @@ inspection." (compile-optional expression)) (& (compile-followed-by expression)) + (-> + (compile-followed-by-not-gen expression)) + (<- + (compile-preceded-by-not-gen expression)) (! (compile-not-followed-by expression)) (character-ranges @@ -1541,6 +1549,32 @@ inspection." :position position :production (result-production result)))))))) +;;; Followed-by-not-gen's + +(defun eval-followed-by-not-gen (expression text position end) + (with-expression (expression (-> subexpr)) + (let ((result (eval-expression subexpr text position end))) + (if (error-result-p result) + (make-failed-parse + :position position + :expression expression + :detail result) + (make-result + :position position))))) + +(defun compile-followed-by-not-gen (expression) + (with-expression (expression (-> subexpr)) + (let ((function (compile-expression subexpr))) + (named-lambda compiled-followed-by-not-gen (text position end) + (let ((result (funcall function text position end))) + (if (error-result-p result) + (make-failed-parse + :position position + :expression expression + :detail result) + (make-result + :position position))))))) + ;;; Not followed-by's (defun eval-not-followed-by (expression text position end) @@ -1565,6 +1599,33 @@ inspection." :expression expression :position position))))))) +;;; Preceded-by's + +(defun eval-preceded-by-not-gen (expression text position end) + (with-expression (expression (<- subexpr)) + (let ((result (eval-expression subexpr text (1- position) end))) + (if (or (error-result-p result) (not (equal (result-position result) position))) + (make-failed-parse + :position position + :expression expression + :detail result) + (make-result + :position position))))) + +(defun compile-preceded-by-not-gen (expression) + (with-expression (expression (<- subexpr)) + (let ((function (compile-expression subexpr))) + (named-lambda compiled-followed-by-not-gen (text position end) + (let ((result (funcall function text (1- position) end))) + (if (or (error-result-p result) (not (equal (result-position result) position))) + (make-failed-parse + :position position + :expression expression + :detail result) + (make-result + :position position))))))) + + ;;; Semantic predicates (defun eval-semantic-predicate (expression text position end) diff --git a/tests.lisp b/tests.lisp index 435700c..bdb474e 100644 --- a/tests.lisp +++ b/tests.lisp @@ -341,7 +341,7 @@ (defun in-context-p (x) (declare (ignore x)) - context) + (and context (not (eql context :void)))) (defrule context (in-context-p "")) (defrule ooc-word word (:constant "out of context word")) @@ -353,6 +353,12 @@ (is (equal "out of context word" (parse '(cond (context word) (t ooc-word)) "foo")))) +(test followed-by-not-gen + (is (equal '("a" nil "b") (parse '(and "a" (-> "b") "b") "ab")))) + +(test preceded-by-not-gen + (is (equal '("a" nil "b") (parse '(and "a" (<- "a") "b") "ab")))) + (defun run-tests () (let ((results (run 'esrap))) (eos:explain! results) From 0da60c19ab9af80e5096078e8b495c6fdbea08cd Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Mon, 29 Apr 2013 01:38:49 +0400 Subject: [PATCH 08/95] Added 'first' operator --- esrap.lisp | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/esrap.lisp b/esrap.lisp index 5cff0a8..9521ac8 100644 --- a/esrap.lisp +++ b/esrap.lisp @@ -1126,6 +1126,8 @@ inspection." (eval-character-ranges expression text position end)) (cond (eval-cond expression text position end)) + (first + (eval-first expression text position end)) (t (if (symbolp (car expression)) (eval-semantic-predicate expression text position end) @@ -1171,6 +1173,8 @@ inspection." (compile-character-ranges expression)) (cond (compile-cond expression)) + (first + (compile-first expression)) (t (if (symbolp (car expression)) (compile-semantic-predicate expression) @@ -1402,8 +1406,6 @@ inspection." ;;; Negations - - (defun exec-negation (fun expr text position end) (if (and (< position end) (error-result-p (funcall fun text position end))) @@ -1459,7 +1461,7 @@ inspection." (named-lambda compiled-times (text position end) (let* ((last nil) (results - (iter (for i from 1 to ,to) + (iter ,@(if to `((for i from 1 to ,to))) (for result next (funcall function text position end)) (until (or (error-result-p (setf last result)) (if-first-time nil @@ -1744,6 +1746,20 @@ inspection." position) :detail last-error))))))))))) +(defun eval-first (expression text position end) + (funcall (compile-first expression) + text position end)) + +(defun compile-first (expression) + (with-expression (expression (first subexpr)) + (let ((function (compile-expression subexpr))) + (named-lambda compiled-first (text position end) + (let ((result (funcall function text position end))) + (if (error-result-p result) + result + (make-result + :position (result-position result) + :production (car (result-production result))))))))) (defvar *indentation-hint-table* nil) From 5a63c9e6ee8a15d75c97b0f55961412e0472162a Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Mon, 29 Apr 2013 01:45:00 +0400 Subject: [PATCH 09/95] Described new syntax in README --- README | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/README b/README index b59381a..e4fad98 100644 --- a/README +++ b/README @@ -56,11 +56,16 @@ Syntax overview: (-> followed-by-not-gen) -- does not consume, produces NIL (<- preceded-by-not-gen) -- succeeds, if preceeded by something of length 1, produces NIL (! not-followed-by) -- does not consume + (cond &rest clauses) -- very analogous to CL's cond statement + (first expr) -- results in CAR of EXPR, if EXPR parses successfully ( expr) -- semantic parsing FROM and TO in (* ...) form may be arbitrary forms (e.g. special variables), but use with caution - feature is experimental and probably does not handle local environment correctly. + Each clause in COND form is of the form (PREDICATE-SUBEXPR VALUE-SUBEXPR). Clauses are executed in order. + First clause, for which PREDICATE-SUBEXPR succeeds and VALUE-SUBEXPR also succeeds, leads VALUE-SUBEXPR. + See file example-sexp.lisp for a complete sample grammar and usage, example-symbol-table.lisp for a grammar with lexical scope, example-very-context-sensitive.lisp for more complex example of context-sensitive grammar, From e993d6465cfbfc3f70b18a68560329715e74150f Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Mon, 29 Apr 2013 21:29:48 +0400 Subject: [PATCH 10/95] Towards multidimensional contexts. --- esrap.lisp | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/esrap.lisp b/esrap.lisp index 9521ac8..7978d4f 100644 --- a/esrap.lisp +++ b/esrap.lisp @@ -37,11 +37,11 @@ (:export #:&bounds - #:context #:! #:? #:+ #:* #:& #:~ #:<- #:-> #:character-ranges #:wrap #:add-rule + #:register-context #:call-transform #:change-rule #:concat @@ -397,9 +397,9 @@ symbols." ;;; For now we just use EQUAL hash-tables, but a specialized ;;; representation would probably pay off. -(defparameter context :void "Context, which is active, when the rule is trying to parse. -Cache depends not only on rule-name and position, but also on the context assumed while -parsing.") +(defparameter contexts nil) +(defmacro register-context (context-sym) + `(push ',context-sym contexts)) (defvar *cache*) @@ -407,10 +407,10 @@ parsing.") (make-hash-table :test #'equal)) (defun get-cached (symbol position cache) - (gethash (list symbol position context) cache)) + (gethash `(,symbol ,position ,@(mapcar #'symbol-value contexts)) cache)) (defun (setf get-cached) (result symbol position cache) - (setf (gethash (list symbol position context) cache) result)) + (setf (gethash `(,symbol ,position ,@(mapcar #'symbol-value contexts)) cache) result)) (defvar *nonterminal-stack* nil) From f7ab8c220f80e4006ba49ac98645c9508c72b39f Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Fri, 3 May 2013 17:28:33 +0400 Subject: [PATCH 11/95] Multidimensional contexts done. --- esrap.lisp | 39 ++++++++++++++++++++------------------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/esrap.lisp b/esrap.lisp index 7978d4f..733b184 100644 --- a/esrap.lisp +++ b/esrap.lisp @@ -1457,25 +1457,26 @@ inspection." (if (equal (length expression) 3) `(0 ,@(cdr expression)) (cdr expression)) - (eval `(let ((function (compile-expression ',subexpr))) - (named-lambda compiled-times (text position end) - (let* ((last nil) - (results - (iter ,@(if to `((for i from 1 to ,to))) - (for result next (funcall function text position end)) - (until (or (error-result-p (setf last result)) - (if-first-time nil - (equal (result-position result) position)))) - (setf position (result-position result)) - (collect result)))) - (if (>= (length results) ,from) - (make-result - :position position - :production (mapcar #'result-production results)) - (make-failed-parse - :position position - :expression ',expression - :detail last)))))))) + (let ((evallee `(let ((function (compile-expression ',subexpr))) + (named-lambda compiled-times (text position end) + (let* ((last nil) + (results + (iter ,@(if to `((for i from 1 to ,to))) + (for result next (funcall function text position end)) + (until (or (error-result-p (setf last result)) + (if-first-time nil + (equal (result-position result) position)))) + (setf position (result-position result)) + (collect result)))) + (if (>= (length results) ,from) + (make-result + :position position + :production (mapcar #'result-production results)) + (make-failed-parse + :position position + :expression ',expression + :detail last))))))) + (eval evallee)))) ;;; Greedy positive repetitions From f73e4f557f0046661ab61deee8b996666b04e6b5 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Sat, 4 May 2013 15:50:19 +0400 Subject: [PATCH 12/95] In FOLLOWED-BY-NOT-GEN EOF can be specified --- esrap.lisp | 30 +++++++++++++++++++++++++----- 1 file changed, 25 insertions(+), 5 deletions(-) diff --git a/esrap.lisp b/esrap.lisp index 733b184..0bd9d82 100644 --- a/esrap.lisp +++ b/esrap.lisp @@ -1556,7 +1556,11 @@ inspection." (defun eval-followed-by-not-gen (expression text position end) (with-expression (expression (-> subexpr)) - (let ((result (eval-expression subexpr text position end))) + (let ((result (if (and (symbolp subexpr) (equal (string subexpr) "EOF")) + (if (equal position end) + (make-result :position position) + (make-failed-parse :expression subexpr :position position)) + (eval-expression subexpr text position end)))) (if (error-result-p result) (make-failed-parse :position position @@ -1567,7 +1571,13 @@ inspection." (defun compile-followed-by-not-gen (expression) (with-expression (expression (-> subexpr)) - (let ((function (compile-expression subexpr))) + (let ((function (if (and (symbolp subexpr) (equal (string subexpr) "EOF")) + (lambda (text position end) + (declare (ignore text)) + (if (equal position end) + (make-result :position position) + (make-failed-parse :expression subexpr :position position))) + (compile-expression subexpr)))) (named-lambda compiled-followed-by-not-gen (text position end) (let ((result (funcall function text position end))) (if (error-result-p result) @@ -1606,7 +1616,11 @@ inspection." (defun eval-preceded-by-not-gen (expression text position end) (with-expression (expression (<- subexpr)) - (let ((result (eval-expression subexpr text (1- position) end))) + (let ((result (if (and (symbolp subexpr) (equal (string subexpr) "SOF")) + (if (equal position 0) + (make-result :position position) + (make-failed-parse :expression subexpr :position position)) + (eval-expression subexpr text (1- position) end)))) (if (or (error-result-p result) (not (equal (result-position result) position))) (make-failed-parse :position position @@ -1617,8 +1631,14 @@ inspection." (defun compile-preceded-by-not-gen (expression) (with-expression (expression (<- subexpr)) - (let ((function (compile-expression subexpr))) - (named-lambda compiled-followed-by-not-gen (text position end) + (let ((function (if (and (symbolp subexpr) (equal (string subexpr) "SOF")) + (lambda (text position end) + (declare (ignore text end)) + (if (equal position -1) + (make-result :position 0) + (make-failed-parse :expression subexpr :position position))) + (compile-expression subexpr)))) + (named-lambda compiled-preceded-by-not-gen (text position end) (let ((result (funcall function text (1- position) end))) (if (or (error-result-p result) (not (equal (result-position result) position))) (make-failed-parse From 347f262bbfc1e5c0086fe4bb6301f4efb69ba482 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Sat, 4 May 2013 21:30:44 +0400 Subject: [PATCH 13/95] - Added tag clause - factored-out common patterns in eval-expression and compile-expression into macrolet --- README | 10 ++++ esrap.lisp | 168 ++++++++++++++++++++++++----------------------------- tests.lisp | 5 ++ 3 files changed, 92 insertions(+), 91 deletions(-) diff --git a/README b/README index e4fad98..fee23ca 100644 --- a/README +++ b/README @@ -58,6 +58,7 @@ Syntax overview: (! not-followed-by) -- does not consume (cond &rest clauses) -- very analogous to CL's cond statement (first expr) -- results in CAR of EXPR, if EXPR parses successfully + (tag tag-kwd expr) -- on the fly tagging of expression ( expr) -- semantic parsing FROM and TO in (* ...) form may be arbitrary forms (e.g. special variables), but use with caution - @@ -65,11 +66,20 @@ Syntax overview: Each clause in COND form is of the form (PREDICATE-SUBEXPR VALUE-SUBEXPR). Clauses are executed in order. First clause, for which PREDICATE-SUBEXPR succeeds and VALUE-SUBEXPR also succeeds, leads VALUE-SUBEXPR. + Tag-clause succeeds, whenever EXPR succeeds, and leads `(,TAG-KWD ,EXPR). It is useful to track, which + alternative of the ordered choice, indeed, realized, like that: + + (or (tag :simple simple-string) + (tag :complex complex-string)) + + without the need of introduction two additional named rules TAGGED-SIMPLE-STRING and TAGGED-COMPLEX-STRING. See file example-sexp.lisp for a complete sample grammar and usage, example-symbol-table.lisp for a grammar with lexical scope, example-very-context-sensitive.lisp for more complex example of context-sensitive grammar, and tests.lisp for various rather trivial use-cases. + Also, package CL-YACLYAML uses all advanced facilities of this parser-generator extensively - so, see code there for + real-life examples. Trivial examples: diff --git a/esrap.lisp b/esrap.lisp index 0bd9d82..24f119b 100644 --- a/esrap.lisp +++ b/esrap.lisp @@ -38,7 +38,7 @@ #:&bounds #:! #:? #:+ #:* #:& #:~ #:<- #:-> - #:character-ranges #:wrap + #:character-ranges #:wrap #:tag #:add-rule #:register-context @@ -1034,6 +1034,9 @@ inspection." (and (every #'validate-expression x) t)) (cdr expression)) t)) + (tag (and (equal (length expression) 3) + (keywordp (cadr expression)) + (validate-expression (caddr expression)))) (t (and (symbolp (car expression)) (cdr expression) (not (cddr expression)) @@ -1089,98 +1092,66 @@ inspection." (%expression-direct-dependencies (second expression) seen)))))) (defun eval-expression (expression text position end) - (typecase expression - ((eql character) - (eval-character text position end)) - (terminal - (if (consp expression) - (eval-terminal (string (second expression)) text position end nil) - (eval-terminal (string expression) text position end t))) - (nonterminal - (eval-nonterminal expression text position end)) - (cons - (case (car expression) - (string - (eval-string expression text position end)) - (and - (eval-sequence expression text position end)) - (or - (eval-ordered-choice expression text position end)) - (not - (eval-negation expression text position end)) - (* (cond ((equal (length expression) 2) (eval-greedy-repetition expression text position end)) - (t (eval-times expression text position end)))) - (+ - (eval-greedy-positive-repetition expression text position end)) - (? - (eval-optional expression text position end)) - (& - (eval-followed-by expression text position end)) - (-> - (eval-followed-by-not-gen expression text position end)) - (<- - (eval-preceded-by-not-gen expression text position end)) - (! - (eval-not-followed-by expression text position end)) - (character-ranges - (eval-character-ranges expression text position end)) - (cond - (eval-cond expression text position end)) - (first - (eval-first expression text position end)) - (t - (if (symbolp (car expression)) - (eval-semantic-predicate expression text position end) - (invalid-expression-error expression))))) - (t - (invalid-expression-error expression)))) + (macrolet ((frob ((&rest clauses) &body body) + `(case (car expression) + ,@(mapcar (lambda (clause) + (let ((clause (if (atom clause) `(,clause) clause))) + `(,(car clause) (,(sb-int:symbolicate "EVAL-" (or (cadr clause) (car clause))) + expression text position end)))) + clauses) + ,@body))) + (typecase expression + ((eql character) + (eval-character text position end)) + (terminal + (if (consp expression) + (eval-terminal (string (second expression)) text position end nil) + (eval-terminal (string expression) text position end t))) + (nonterminal + (eval-nonterminal expression text position end)) + (cons + (frob (string (and sequence) (or ordered-choice) (not negation) + (+ greedy-positive-repetition) (? optional) (& followed-by) (-> followed-by-not-gen) + (<- preceded-by-not-gen) (! not-followed-by) character-ranges cond first tag) + (* (cond ((equal (length expression) 2) (eval-greedy-repetition expression text position end)) + (t (eval-times expression text position end)))) + (t + (if (symbolp (car expression)) + (eval-semantic-predicate expression text position end) + (invalid-expression-error expression))))) + (t + (invalid-expression-error expression))))) (defun compile-expression (expression) - (etypecase expression - ((eql character) - (compile-character)) - (terminal - (if (consp expression) - (compile-terminal (string (second expression)) nil) - (compile-terminal (string expression) t))) - (nonterminal - (compile-nonterminal expression)) - (cons - (case (car expression) - (string - (compile-string expression)) - (and - (compile-sequence expression)) - (or - (compile-ordered-choice expression)) - (not - (compile-negation expression)) - (* (cond ((equal (length expression) 2) (compile-greedy-repetition expression)) - (t (compile-times expression)))) - (+ - (compile-greedy-positive-repetition expression)) - (? - (compile-optional expression)) - (& - (compile-followed-by expression)) - (-> - (compile-followed-by-not-gen expression)) - (<- - (compile-preceded-by-not-gen expression)) - (! - (compile-not-followed-by expression)) - (character-ranges - (compile-character-ranges expression)) - (cond - (compile-cond expression)) - (first - (compile-first expression)) - (t - (if (symbolp (car expression)) - (compile-semantic-predicate expression) - (invalid-expression-error expression))))) - (t - (invalid-expression-error expression)))) + (macrolet ((frob ((&rest clauses) &body body) + `(case (car expression) + ,@(mapcar (lambda (clause) + (let ((clause (if (atom clause) `(,clause) clause))) + `(,(car clause) (,(sb-int:symbolicate "COMPILE-" (or (cadr clause) (car clause))) + expression)))) + clauses) + ,@body))) + (etypecase expression + ((eql character) + (compile-character)) + (terminal + (if (consp expression) + (compile-terminal (string (second expression)) nil) + (compile-terminal (string expression) t))) + (nonterminal + (compile-nonterminal expression)) + (cons + (frob (string (and sequence) (or ordered-choice) (not negation) + (+ greedy-positive-repetition) (? optional) (& followed-by) (-> followed-by-not-gen) + (<- preceded-by-not-gen) (! not-followed-by) character-ranges cond first tag) + (* (cond ((equal (length expression) 2) (compile-greedy-repetition expression)) + (t (compile-times expression)))) + (t + (if (symbolp (car expression)) + (compile-semantic-predicate expression) + (invalid-expression-error expression))))) + (t + (invalid-expression-error expression))))) ;;; Characters and strings @@ -1429,6 +1400,21 @@ inspection." (named-lambda compiled-negation (text position end) (exec-negation sub expression text position end))))) +;;; On-the-fly tagging +(defun eval-tag (expression text position end) + (funcall (compile-tag expression) text position end)) + +(defun compile-tag (expression) + (with-expression (expression (tag keyword subexpr)) + (let ((function (compile-expression subexpr))) + (named-lambda compiled-tag (text position end) + (let ((result (funcall function text position end))) + (if (error-result-p result) + result + (make-result + :position (result-position result) + :production `(,keyword ,(result-production result))))))))) + ;;; Greedy repetitions (defun eval-greedy-repetition (expression text position end) diff --git a/tests.lisp b/tests.lisp index bdb474e..ddc030d 100644 --- a/tests.lisp +++ b/tests.lisp @@ -339,6 +339,8 @@ (defrule cond-word (cond (dyna-from-to word))) +(defparameter context :void) + (defun in-context-p (x) (declare (ignore x)) (and context (not (eql context :void)))) @@ -359,6 +361,9 @@ (test preceded-by-not-gen (is (equal '("a" nil "b") (parse '(and "a" (<- "a") "b") "ab")))) +(test on-the-fly-tagging + (is (equal '(:simple-tag "aaa") (parse '(tag :simple-tag "aaa") "aaa")))) + (defun run-tests () (let ((results (run 'esrap))) (eos:explain! results) From 52f95b7f05c14765773c878b76331bc2a5a85da9 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Sat, 1 Jun 2013 00:40:12 +0400 Subject: [PATCH 14/95] Add explanation of the idea of liquid branch --- README | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/README b/README index fee23ca..da7931d 100644 --- a/README +++ b/README @@ -1,5 +1,10 @@ ESRAP -- a packrat parser for Common Lisp +This branch attempts to intergrate DEFRULE macro and COMPILE-EXPRESSION and EVAL-EXPRESSION functions +into a single macro, where no manual code-walking is done and all the wisardy is done through +MACROLET and SYMBOL-MACROLET's and the like. +I hope, that it will allow to write a code that's more flexible, hence the name of the branch - liquid. + In addition to regular Packrat / Parsing Grammar / TDPL features ESRAP supports: From cbde7fbd9db117a3c4bcc4b70dfacebde635c8a3 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Sat, 1 Jun 2013 04:59:58 +0400 Subject: [PATCH 15/95] A few first strokes --- esrap.lisp | 138 ++++++++++++++++++++++------------------------------- 1 file changed, 56 insertions(+), 82 deletions(-) diff --git a/esrap.lisp b/esrap.lisp index 24f119b..42db375 100644 --- a/esrap.lisp +++ b/esrap.lisp @@ -1155,65 +1155,54 @@ inspection." ;;; Characters and strings -(declaim (inline exec-string)) -(defun exec-string (length text position end) - (let ((limit (+ length position))) +(defmacro! any-string (length) + (let ((expression '(any-string ,length)) + (limit (+ ,length position))) (if (<= limit end) (make-result :production (subseq text position limit) :position limit) - (make-failed-parse - :expression `(string ,length) - :position position)))) + (fail "Unable to parse any string of specified length.")))) -(defun eval-character (text position end) - (if (< position end) - (make-result - :production (char text position) - :position (1+ position)) - (make-failed-parse - :expression 'character - :position position))) - -(defun compile-character () - #'eval-character) +(define-symbol-macro character + (let ((expression 'character)) + (if (< position end) + (make-result + :production (char text position) + :position (1+ position)) + (fail "EOF reached while trying to parse character.")))) -(defun eval-string (expression text position end) - (with-expression (expression (string length)) - (exec-string length text position end))) - -(defun compile-string (expression) - (with-expression (expression (string length)) - (named-lambda compiled-string (text position end) - (exec-string length text position end)))) ;;; Terminals ;;; ;;; FIXME: It might be worth it to special-case terminals of length 1. -(declaim (inline match-terminal-p)) -(defun match-terminal-p (string length text position end case-sensitive-p) - (and (<= (+ length position) end) - (if case-sensitive-p - (string= string text :start2 position :end2 (+ position length)) - (string-equal string text :start2 position :end2 (+ position length))))) - -(defun exec-terminal (string length text position end case-sensitive-p) - (if (match-terminal-p string length text position end case-sensitive-p) - (make-result - :position (+ length position) - :production string) - (make-failed-parse - :expression string - :position position))) - -(defun eval-terminal (string text position end case-sensitive-p) - (exec-terminal string (length string) text position end case-sensitive-p)) - -(defun compile-terminal (string case-sensitive-p) - (let ((length (length string))) - (named-lambda compiled-terminal (text position end) - (exec-terminal string length text position end case-sensitive-p)))) +;;; #]foo[ denotes literal string terminal "foo" +(set-dispatch-macro-character #\# #\] + (lambda (stream subchar arg) + (declare (ignore subchar arg)) + `(terminal ,(sb-impl::read-string stream #\[) nil))) + +(set-dispatch-macro-character #\# #\/ (let ((f (get-dispatch-macro-character #\# #\\))) + (lambda (stream subchar arg) + (let ((char (funcall f stream subchar arg))) + `(terminal ,char nil))))) + +(defmacro terminal (terminal case-insensitive) + (let ((length (length terminal)) + (terminal (string terminal))) + `(if (and (<= (+ ,length position) end) + ,(if case-insensitive + `(string-equal ,terminal text :start2 position :end2 (+ position ,length)) + `(string= ,terminal text :start2 position :end2 (+ position ,length)))) + (make-result + :position (+ ,length position) + :production '(terminal ,terminal)) + (fail)))) + +(defmacro! ~ (terminal) + "Expands into case-insensitive terminal checking." + `(terminal ,terminal t)) ;;; Nonterminals @@ -1235,40 +1224,25 @@ inspection." ;;; FIXME: It might be better if we actually chained the closures ;;; here, instead of looping over them -- benchmark first, though. -(defun eval-sequence (expression text position end) - (with-expression (expression (and &rest subexprs)) - (let (results) - (dolist (expr subexprs - (make-result - :position position - :production (mapcar #'result-production (nreverse results)))) - (let ((result (eval-expression expr text position end))) - (if (error-result-p result) - (return (make-failed-parse - :expression expression - :position position - :detail result)) - (setf position (result-position result))) - (push result results)))))) - -(defun compile-sequence (expression) - (with-expression (expression (and &rest subexprs)) - (let ((functions (mapcar #'compile-expression subexprs))) - (named-lambda compiled-sequence (text position end) - (let (results) - (dolist (fun functions - (make-result - :position position - :production (mapcar #'result-production (nreverse results)))) - (let ((result (funcall fun text position end))) - (if (error-result-p result) - (return (make-failed-parse - :expression expression - :position position - :detail result)) - (setf position (result-position result))) - (push result results)))))))) - +(defmacro! fail (detail) + `(error 'parse-error + :expression expression + :position position + :detail ,detail)) + + +(defmacro! && (&rest subexpressions) + `(let ((,g!-subexprs (list ,@(mapcar (lambda (x) `(lambda () + (let ((expression ',x)) + ,x)) + subexpressions))))) + (iter (for ,g!-subexpr in ,g!-subexprs) + (let ((,g!-result (funcall ,g!-subexpr))) + (if (error-result-p ,g!-result) + (fail ,g!-result) + (progn (setf position (result-position ,g!-result)) + (collect (result-production ,g!-result)))))))) + ;;; Ordered choices (defun eval-ordered-choice (expression text position end) From d09770e7f3bce8fd4eded441d19ca21efa7f0724 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Wed, 23 Oct 2013 18:44:40 +0400 Subject: [PATCH 16/95] Liquefication starts --- conditions.lisp | 90 +++++++++ esrap.asd | 12 +- esrap.lisp | 490 +--------------------------------------------- memoization.lisp | 53 +++++ miscellany.lisp | 92 +++++++++ package.lisp | 37 ++++ rule-storage.lisp | 140 +++++++++++++ 7 files changed, 423 insertions(+), 491 deletions(-) create mode 100644 conditions.lisp create mode 100644 memoization.lisp create mode 100644 miscellany.lisp create mode 100644 package.lisp create mode 100644 rule-storage.lisp diff --git a/conditions.lisp b/conditions.lisp new file mode 100644 index 0000000..f82d682 --- /dev/null +++ b/conditions.lisp @@ -0,0 +1,90 @@ +;;;; conditions.lisp + +(in-package :esrap) + +(define-condition esrap-error (parse-error) + ((text :initarg :text :initform nil :reader esrap-error-text) + (position :initarg :position :initform nil :reader esrap-error-position) + (reason :initarg :reason :initform nil :reader esrap-error-reason)) + (:documentation + "Signaled when an Esrap parse fails. Use ESRAP-ERROR-TEXT to obtain the +string that was being parsed, and ESRAP-ERROR-POSITION the position at which +the error occurred.")) + +(defmethod print-object ((condition esrap-error) stream) + (if *print-escape* + (call-next-method) + ;; FIXME: this looks like it won't do the right thing when used as part of a + ;; logical block. + (when (or (not *print-lines*) (> *print-lines* 1)) + (if-let ((text (esrap-error-text condition)) + (position (esrap-error-position condition))) + (let* ((line (count #\Newline text :end position)) + (column (- position (or (position #\Newline text + :end position + :from-end t) + 0) + 1)) + ;; FIXME: magic numbers + (start (or (position #\Newline text + :start (max 0 (- position 32)) + :end (max 0 (- position 24)) + :from-end t) + (max 0 (- position 24)))) + (end (min (length text) (+ position 24))) + (newline (or (position #\Newline text + :start start + :end position + :from-end t) + start)) + (*print-circle* nil)) + (format stream "~2&~A~2& Encountered at:~% ~ + ~A~% ~ + ~V@T^ (Line ~D, Column ~D, Position ~D)~%" + (if-let ((reason (esrap-error-reason condition))) + reason + "No particular reason") + (if (emptyp text) + "" + (subseq text start end)) + (- position newline) + (1+ line) (1+ column) + position)) + (format stream "~2& "))))) + +(define-condition simple-esrap-error (esrap-error simple-condition) ()) + +(defmethod print-object :before ((condition simple-esrap-error) stream) + (apply #'format stream + (simple-condition-format-control condition) + (simple-condition-format-arguments condition))) + +(declaim (ftype (function (t t t &rest t) (values nil &optional)) + simple-esrap-error)) +(defun simple-esrap-error (text position reason format-control &rest format-arguments) + (error 'simple-esrap-error + :text text + :position position + :reason reason + :format-control format-control + :format-arguments format-arguments)) + +(defmacro fail-parse (&optional (reason "No particular reason.") &rest args) + `(let ((reason (apply #'format `(nil ,,reason ,,@args)))) + (simple-esrap-error text position reason "~a~%" reason))) + + +(define-condition left-recursion (esrap-error) + ((nonterminal :initarg :nonterminal :initform nil :reader left-recursion-nonterminal) + (path :initarg :path :initform nil :reader left-recursion-path)) + (:documentation + "Signaled when left recursion is detected during Esrap parsing. +LEFT-RECURSION-NONTERMINAL names the symbol for which left recursion was +detected, and LEFT-RECURSION-PATH lists nonterminals of which the left +recursion cycle consists.")) + +(defmethod print-object :before ((condition left-recursion) stream) + (format stream "Left recursion in nonterminal ~S. ~_Path: ~ + ~{~S~^ -> ~}" + (left-recursion-nonterminal condition) + (left-recursion-path condition))) diff --git a/esrap.asd b/esrap.asd index 26b7afd..26f78f9 100644 --- a/esrap.asd +++ b/esrap.asd @@ -22,11 +22,15 @@ (in-package :esrap-system) (defsystem :esrap - :version "0.9" + :version "1.1" ; odd minor version numbers are for unstable versions :description "A Packrat / Parsing Grammar / TDPL parser for Common Lisp." :licence "MIT" - :depends-on (:alexandria :defmacro-enhance :iterate :rutils) - :components ((:file "esrap") + :depends-on (:alexandria :defmacro-enhance :iterate :rutils :cl-indeterminism) + :serial t + :components ((:file "package") + (:file "conditions") + (:file "miscellany") + (:file "esrap") (:static-file "example-sexp.lisp") (:static-file "example-symbol-table.lisp") (:static-file "README"))) @@ -34,7 +38,7 @@ (defsystem :esrap-tests :description "Tests for ESRAP." :licence "MIT" - :depends-on (:esrap :eos) + :depends-on (:esrap :fiveam) :components ((:file "tests"))) (defmethod perform ((op test-op) (sys (eql (find-system :esrap)))) diff --git a/esrap.lisp b/esrap.lisp index 42db375..5416fe1 100644 --- a/esrap.lisp +++ b/esrap.lisp @@ -29,353 +29,12 @@ ;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -(defpackage :esrap - (:use :cl :alexandria :defmacro-enhance :iterate) - (:shadowing-import-from :rutils.string :strcat) - #+sbcl - (:lock t) - (:export - #:&bounds - - #:! #:? #:+ #:* #:& #:~ #:<- #:-> - #:character-ranges #:wrap #:tag - - #:add-rule - #:register-context - #:call-transform - #:change-rule - #:concat - #:defrule - #:describe-grammar - #:esrap-error - #:esrap-error-position - #:esrap-error-text - #:find-rule - #:left-recursion - #:left-recursion-nonterminal - #:left-recursion-path - #:parse - #:remove-rule - #:rule - #:rule-dependencies - #:rule-expression - #:rule-symbol - #:text - #:trace-rule - #:untrace-rule - )) - (in-package :esrap) -;;; Conditions - -(defun foo () nil) - -(define-condition esrap-error (parse-error) - ((text :initarg :text :initform nil :reader esrap-error-text) - (position :initarg :position :initform nil :reader esrap-error-position)) - (:documentation - "Signaled when an Esrap parse fails. Use ESRAP-ERROR-TEXT to obtain the -string that was being parsed, and ESRAP-ERROR-POSITION the position at which -the error occurred.")) - -(defmethod print-object ((condition esrap-error) stream) - (if *print-escape* - (call-next-method) - ;; FIXME: this looks like it won't do the right thing when used as part of a - ;; logical block. - (when (or (not *print-lines*) (> *print-lines* 1)) - (if-let ((text (esrap-error-text condition)) - (position (esrap-error-position condition))) - (let* ((line (count #\Newline text :end position)) - (column (- position (or (position #\Newline text - :end position - :from-end t) - 0) - 1)) - ;; FIXME: magic numbers - (start (or (position #\Newline text - :start (max 0 (- position 32)) - :end (max 0 (- position 24)) - :from-end t) - (max 0 (- position 24)))) - (end (min (length text) (+ position 24))) - (newline (or (position #\Newline text - :start start - :end position - :from-end t) - start)) - (*print-circle* nil)) - (format stream "~2& Encountered at:~% ~ - ~A~% ~ - ~V@T^ (Line ~D, Column ~D, Position ~D)~%" - (if (emptyp text) - "" - (subseq text start end)) - (- position newline) - (1+ line) (1+ column) - position)) - (format stream "~2& "))))) - -(define-condition simple-esrap-error (esrap-error simple-condition) ()) - -(defmethod print-object :before ((condition simple-esrap-error) stream) - (apply #'format stream - (simple-condition-format-control condition) - (simple-condition-format-arguments condition))) - -(declaim (ftype (function (t t t &rest t) (values nil &optional)) - simple-esrap-error)) -(defun simple-esrap-error (text position format-control &rest format-arguments) - (error 'simple-esrap-error - :text text - :position position - :format-control format-control - :format-arguments format-arguments)) - -(define-condition left-recursion (esrap-error) - ((nonterminal :initarg :nonterminal :initform nil :reader left-recursion-nonterminal) - (path :initarg :path :initform nil :reader left-recursion-path)) - (:documentation - "Signaled when left recursion is detected during Esrap parsing. -LEFT-RECURSION-NONTERMINAL names the symbol for which left recursion was -detected, and LEFT-RECURSION-PATH lists nonterminals of which the left -recursion cycle consists.")) - -(defmethod print-object :before ((condition left-recursion) stream) - (format stream "Left recursion in nonterminal ~S. ~_Path: ~ - ~{~S~^ -> ~}" - (left-recursion-nonterminal condition) - (left-recursion-path condition))) - -;;; Miscellany - -(defun text (&rest arguments) - "Arguments must be strings, or lists whose leaves are strings. -Catenates all the strings in arguments into a single string." - (with-output-to-string (s) - (labels ((cat-list (list) - (dolist (elt list) - (etypecase elt - (string (write-string elt s)) - (character (write-char elt s)) - (list (cat-list elt)))))) - (cat-list arguments)))) - -(setf (symbol-function 'concat) (symbol-function 'text)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun note-deprecated (old new) - (warn 'simple-style-warning - :format-control "~S is deprecated, use ~S instead." - :format-arguments (list old new)))) - -(define-compiler-macro concat (&whole form &rest arguments) - (declare (ignore arguments)) - (note-deprecated 'concat 'text) - form) - -(defun text/bounds (strings start end) - (declare (ignore start end)) - (text strings)) - -(defun lambda/bounds (function) - (lambda (result start end) - (declare (ignore start end)) - (funcall function result))) - -(defun identity/bounds (identity start end) - (declare (ignore start end)) - identity) - -(defun parse-lambda-list-maybe-containing-&bounds (lambda-list) - "Parse &BOUNDS section in LAMBDA-LIST and return three values: - -1. The standard lambda list sublist of LAMBDA-LIST -2. A symbol that should be bound to the start of a matching substring -3. A symbol that should be bound to the end of a matching substring -4. A list containing symbols that were GENSYM'ed. - -The second and/or third values are GENSYMS if LAMBDA-LIST contains a -partial or no &BOUNDS section, in which case fourth value contains them -for use with IGNORE." - (let ((length (length lambda-list))) - (multiple-value-bind (lambda-list start end gensyms) - (cond - ;; Look for &BOUNDS START END. - ((and (>= length 3) - (eq (nth (- length 3) lambda-list) '&bounds)) - (values (subseq lambda-list 0 (- length 3)) - (nth (- length 2) lambda-list) - (nth (- length 1) lambda-list) - nil)) - ;; Look for &BOUNDS START. - ((and (>= length 2) - (eq (nth (- length 2) lambda-list) '&bounds)) - (let ((end (gensym "END"))) - (values (subseq lambda-list 0 (- length 2)) - (nth (- length 1) lambda-list) - end - (list end)))) - ;; No &BOUNDS section. - (t - (let ((start (gensym "START")) - (end (gensym "END"))) - (values lambda-list - start - end - (list start end))))) - (check-type start symbol) - (check-type end symbol) - (values lambda-list start end gensyms)))) - -(deftype nonterminal () - "Any symbol except CHARACTER and NIL can be used as a nonterminal symbol." - '(and symbol (not (member character nil)))) - -(deftype terminal () - "Literal strings and characters are used as case-sensitive terminal symbols, -and expressions of the form \(~ ) denote case-insensitive terminals." - `(or string character - (cons (eql ~) (cons (or string character) null)))) - -;;; RULE REPRESENTATION AND STORAGE -;;; -;;; For each rule, there is a RULE-CELL in *RULES*, whose %INFO slot has the -;;; function that implements the rule in car, and the rule object in CDR. A -;;; RULE object can be attached to only one non-terminal at a time, which is -;;; accessible via RULE-SYMBOL. - -(defvar *rules* (make-hash-table)) - -(defun clear-rules () - (clrhash *rules*) - nil) - -(defstruct (rule-cell (:constructor - make-rule-cell - (symbol &aux (%info (cons (undefined-rule-function symbol) nil)))) - (:conc-name cell-)) - (%info (required-argument) :type (cons function t)) - (trace-info nil) - (referents nil :type list)) - -(declaim (inline cell-function)) -(defun cell-function (cell) - (car (cell-%info cell))) - -(defun cell-rule (cell) - (cdr (cell-%info cell))) - -(defun set-cell-info (cell function rule) - ;; Atomic update - (setf (cell-%info cell) (cons function rule)) - (let ()) - cell) - -(defun undefined-rule-function (symbol) - (lambda (&rest args) - (declare (ignore args)) - (error "Undefined rule: ~S" symbol))) - -(defun ensure-rule-cell (symbol) - (check-type symbol nonterminal) - ;; FIXME: Need to lock *RULES*. - (or (gethash symbol *rules*) - (setf (gethash symbol *rules*) - (make-rule-cell symbol)))) - -(defun delete-rule-cell (symbol) - (remhash symbol *rules*)) - -(defun reference-rule-cell (symbol referent) - (let ((cell (ensure-rule-cell symbol))) - (when referent - (pushnew referent (cell-referents cell))) - cell)) - -(defun dereference-rule-cell (symbol referent) - (let ((cell (ensure-rule-cell symbol))) - (setf (cell-referents cell) (delete referent (cell-referents cell))) - cell)) - -(defun find-rule-cell (symbol) - (check-type symbol nonterminal) - (gethash symbol *rules*)) - -(defclass rule () - ((%symbol - :initform nil) - (%expression - :initarg :expression - :initform (required-argument :expression)) - (%guard-expression - :initarg :guard-expression - :initform t - :reader rule-guard-expression) - ;; Either T for rules that are always active (the common case), - ;; NIL for rules that are never active, or a function to call - ;; to find out if the rule is active or not. - (%condition - :initarg :condition - :initform t - :reader rule-condition) - (%transform - :initarg :transform - :initform nil - :reader rule-transform) - (%around - :initarg :around - :initform nil - :reader rule-around))) - -(defun rule-symbol (rule) - "Returns the nonterminal associated with the RULE, or NIL of the rule -is not attached to any nonterminal." - (slot-value rule '%symbol)) - -(defun detach-rule (rule) - (dolist (dep (%rule-direct-dependencies rule)) - (dereference-rule-cell dep (rule-symbol rule))) - (setf (slot-value rule '%symbol) nil)) - -(defmethod shared-initialize :after ((rule rule) slots &key) - (validate-expression (rule-expression rule))) - -(defmethod print-object ((rule rule) stream) - (print-unreadable-object (rule stream :type t :identity nil) - (let ((symbol (rule-symbol rule))) - (if symbol - (format stream "~S <- " symbol) - (format stream "(detached) "))) - (write (rule-expression rule) :stream stream))) - -(defun sort-dependencies (symbol dependencies) - (let ((symbols (delete symbol dependencies)) - (defined nil) - (undefined nil)) - (dolist (sym symbols) - (if (find-rule sym) - (push sym defined) - (push sym undefined))) - (values defined undefined))) - -(defun rule-dependencies (rule) - "Returns the dependencies of the RULE: primary value is a list of defined -nonterminal symbols, and secondary value is a list of undefined nonterminal -symbols." - (sort-dependencies - (rule-symbol rule) (%expression-dependencies (rule-expression rule) nil))) - -(defun rule-direct-dependencies (rule) - (sort-dependencies - (rule-symbol rule) (%expression-direct-dependencies (rule-expression rule) nil))) - -(defun %rule-direct-dependencies (rule) - (delete (rule-symbol rule) (%expression-direct-dependencies (rule-expression rule) nil))) ;;; Expression destructuring and validation +;;; TODO: Probably this won't be needed, once liquification is complete (defmacro with-expression ((expr lambda-list) &body body) (let* ((type (car lambda-list)) (car-var (gensym "CAR")) @@ -388,55 +47,6 @@ symbols." (error "~S-expression expected, got: ~S" ',type ,expr))) (locally ,@body))))) -;;; MEMOIZATION CACHE -;;; -;;; Because each [rule, position] tuple has an unambiguous -;;; result per source text, we can cache this result -- this is what -;;; makes packrat parsing O(N). -;;; -;;; For now we just use EQUAL hash-tables, but a specialized -;;; representation would probably pay off. - -(defparameter contexts nil) -(defmacro register-context (context-sym) - `(push ',context-sym contexts)) - -(defvar *cache*) - -(defun make-cache () - (make-hash-table :test #'equal)) - -(defun get-cached (symbol position cache) - (gethash `(,symbol ,position ,@(mapcar #'symbol-value contexts)) cache)) - -(defun (setf get-cached) (result symbol position cache) - (setf (gethash `(,symbol ,position ,@(mapcar #'symbol-value contexts)) cache) result)) - -(defvar *nonterminal-stack* nil) - -(defun hash->assoc (hash) - (iter (for (key val) in-hashtable hash) - (collect `(,key . ,val)))) - -;;; SYMBOL, POSITION, and CACHE must all be lexical variables! -(defmacro with-cached-result ((symbol position &optional (text nil)) &body forms) - (with-gensyms (cache result) - `(let* ((,cache *cache*) - (,result (get-cached ,symbol ,position ,cache)) - (*nonterminal-stack* (cons ,symbol *nonterminal-stack*))) - (cond ((eq t ,result) - (error 'left-recursion - :text ,text - :position ,position - :nonterminal ,symbol - :path (reverse *nonterminal-stack*))) - (,result - ,result) - (t - ;; First mark this pair with T to detect left-recursion, - ;; then compute the result and cache that. - (setf (get-cached ,symbol ,position ,cache) t - (get-cached ,symbol ,position ,cache) (locally ,@forms))))))) ;;; RESULT REPRESENTATION ;;; @@ -545,103 +155,9 @@ are allowed only if JUNK-ALLOWED is true." position (simple-esrap-error text position "Incomplete parse."))))))) -(defmacro! defrule (&whole form symbol expression &body options) +(defmacro! defrule (&whole form symbol expression check) "Define SYMBOL as a nonterminal, using EXPRESSION as associated the parsing expression. - -Following OPTIONS can be specified: - - * (:WHEN TEST) - - The rule is active only when TEST evaluates to true. This can be used - to specify optional extensions to a grammar. - - * (:CONSTANT CONSTANT) - - No matter what input is consumed or what EXPRESSION produces, the production - of the rule is always CONSTANT. - - * (:FUNCTION FUNCTION) - - If provided the production of the expression is transformed using - FUNCTION. FUNCTION can be a function name or a lambda-expression. - - * (:IDENTITY BOOLEAN) - - If true, the production of expression is used as-is, as if (:FUNCTION IDENTITY) - has been specified. If no production option is specified, this is the default. - - * (:TEXT BOOLEAN) - - If true, the production of expression is flattened and concatenated into a string - as if by (:FUNCTION TEXT) has been specified. - - * (:LAMBDA LAMBDA-LIST &BODY BODY) - - If provided, same as using the corresponding lambda-expression with :FUNCTION. - - As an extension of the standard lambda list syntax, LAMBDA-LIST accepts - the optional pseudo lambda-list keyword ESRAP:&BOUNDS, which (1) must appear - after all standard lambda list keywords. (2) can be followed by one or two - variables to which bounding indexes of the matching substring are bound. - - Therefore: - - LAMBDA-LIST ::= (STANDARD-LAMBDA-LIST-ELEMENTS [&BOUNDS START [END]]) - - * (:DESTRUCTURE DESTRUCTURING-LAMBDA-LIST &BODY BODY) - - If provided, same as using a lambda-expression that destructures its argument - using DESTRUCTURING-BIND and the provided lambda-list with :FUNCTION. - - DESTRUCTURING-LAMBDA-LIST can use ESRAP:&BOUNDS in the same way - as described for :LAMBDA. - - * (:AROUND ([&BOUNDS START [END]]) &BODY BODY) - - If provided, execute BODY around the construction of the production of the - rule. BODY has to call ESRAP:CALL-TRANSFORM to trigger the computation of - the production. Any transformation provided via :LAMBDA, :FUNCTION - or :DESTRUCTURE is executed inside the call to ESRAP:CALL-TRANSFORM. As a - result, modification to the dynamic state are visible within the - transform. - - ESRAP:&BOUNDS can be used in the same way as described for :LAMBDA - and :DESTRUCTURE. - - This option can be used to safely track nesting depth, manage symbol - tables or for other stack-like operations. - * (:WRAP-AROUND &BODY BODY) - - Another way to perform stack-like operations. - Shadows everything, that's specified in the :AROUND clause. - If used, it is assumed, that EXPRESSION is of the form (LIST 'WRAP WRAPPER WRAPPIE), - where WRAPPER and WRAPPIE are arbitrary expressions, not containing WRAP. - All this being the case, parsing of a rule proceeds as follows: - * first, WRAPPER is parsed. - * if that succeeds, BODY is executed, with WRAPPER bound to result of parsing - WRAPPER, and PARSER bound to thunk to parse WRAPPIE. - Additionally, CALL-PARSER is synonym to (FUNCALL PARSER), - just to mimick CALL-TRANSFORM of original :AROUND clause. - - Typical use-case would be: - - (defrule my-wrapping-rule (wrap wrapper wrappie) - (:wrap-around (let ((context-var-1 (car wrapper)) ; set dynamic state based on WRAPPER - (context-var-2 (cadr wrapper))) - (call-parser))) ; trigger further parsing - (:lambda (lst) ; LST here is result of parsing WRAPPIE - (list :context `(,context-var-1 ,context-var-2) ; yep, we are inside the context - :content lst))) ; designated by the wrapper. - - If that sounds a little bit confusing, see test-suite DYNAMIC-WRAPPING - in TESTS.LISP and EXAMPLE-VERY-CONTEXT-SENSITIVE.LISP for examples. - This feature was introduced to express rules for reading block-scalars in YaML, - hence, see www.yaml.org for the specification of block scalars and the idea of why - this feature is needed. - - Since no parsing of a WRAPPIE is occured at the time BODY is executed, nothing sensible - can be bound to &BOUNDS. -" +Rule is only succeeds, if CHECK evaluates to true." (let ((transform nil) (around nil) (guard t) diff --git a/memoization.lisp b/memoization.lisp new file mode 100644 index 0000000..b155d03 --- /dev/null +++ b/memoization.lisp @@ -0,0 +1,53 @@ +;;;; memoization.lisp + +;;; MEMOIZATION CACHE +;;; +;;; Because each [rule, position] tuple has an unambiguous +;;; result per source text, we can cache this result -- this is what +;;; makes packrat parsing O(N). +;;; +;;; For now we just use EQUAL hash-tables, but a specialized +;;; representation would probably pay off. + +(in-package :esrap) + +(defparameter contexts nil) +(defmacro register-context (context-sym) + `(push ',context-sym contexts)) + +(defvar *cache*) + +(defun make-cache () + (make-hash-table :test #'equal)) + +(defun get-cached (symbol position cache) + (gethash `(,symbol ,position ,@(mapcar #'symbol-value contexts)) cache)) + +(defun (setf get-cached) (result symbol position cache) + (setf (gethash `(,symbol ,position ,@(mapcar #'symbol-value contexts)) cache) result)) + +(defvar *nonterminal-stack* nil) + +(defun hash->assoc (hash) + (iter (for (key val) in-hashtable hash) + (collect `(,key . ,val)))) + +;;; SYMBOL, POSITION, and CACHE must all be lexical variables! +(defmacro with-cached-result ((symbol position &optional (text nil)) &body forms) + (with-gensyms (cache result) + `(let* ((,cache *cache*) + (,result (get-cached ,symbol ,position ,cache)) + (*nonterminal-stack* (cons ,symbol *nonterminal-stack*))) + (cond ((eq t ,result) + (error 'left-recursion + :text ,text + :position ,position + :nonterminal ,symbol + :path (reverse *nonterminal-stack*))) + (,result + ,result) + (t + ;; First mark this pair with T to detect left-recursion, + ;; then compute the result and cache that. + (setf (get-cached ,symbol ,position ,cache) t + (get-cached ,symbol ,position ,cache) (locally ,@forms))))))) diff --git a/miscellany.lisp b/miscellany.lisp new file mode 100644 index 0000000..e01e4ed --- /dev/null +++ b/miscellany.lisp @@ -0,0 +1,92 @@ +;;; miscellany.lisp + +(in-package :esrap) + +(defun text (&rest arguments) + "Arguments must be strings, or lists whose leaves are strings. +Catenates all the strings in arguments into a single string." + (with-output-to-string (s) + (labels ((cat-list (list) + (dolist (elt list) + (etypecase elt + (string (write-string elt s)) + (character (write-char elt s)) + (list (cat-list elt)))))) + (cat-list arguments)))) + +(setf (symbol-function 'concat) (symbol-function 'text)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun note-deprecated (old new) + (warn 'simple-style-warning + :format-control "~S is deprecated, use ~S instead." + :format-arguments (list old new)))) + +(define-compiler-macro concat (&whole form &rest arguments) + (declare (ignore arguments)) + (note-deprecated 'concat 'text) + form) + +(defun text/bounds (strings start end) + (declare (ignore start end)) + (text strings)) + +(defun lambda/bounds (function) + (lambda (result start end) + (declare (ignore start end)) + (funcall function result))) + +(defun identity/bounds (identity start end) + (declare (ignore start end)) + identity) + +(defun parse-lambda-list-maybe-containing-&bounds (lambda-list) + "Parse &BOUNDS section in LAMBDA-LIST and return three values: + +1. The standard lambda list sublist of LAMBDA-LIST +2. A symbol that should be bound to the start of a matching substring +3. A symbol that should be bound to the end of a matching substring +4. A list containing symbols that were GENSYM'ed. + +The second and/or third values are GENSYMS if LAMBDA-LIST contains a +partial or no &BOUNDS section, in which case fourth value contains them +for use with IGNORE." + (let ((length (length lambda-list))) + (multiple-value-bind (lambda-list start end gensyms) + (cond + ;; Look for &BOUNDS START END. + ((and (>= length 3) + (eq (nth (- length 3) lambda-list) '&bounds)) + (values (subseq lambda-list 0 (- length 3)) + (nth (- length 2) lambda-list) + (nth (- length 1) lambda-list) + nil)) + ;; Look for &BOUNDS START. + ((and (>= length 2) + (eq (nth (- length 2) lambda-list) '&bounds)) + (let ((end (gensym "END"))) + (values (subseq lambda-list 0 (- length 2)) + (nth (- length 1) lambda-list) + end + (list end)))) + ;; No &BOUNDS section. + (t + (let ((start (gensym "START")) + (end (gensym "END"))) + (values lambda-list + start + end + (list start end))))) + (check-type start symbol) + (check-type end symbol) + (values lambda-list start end gensyms)))) + +(deftype nonterminal () + "Any symbol except CHARACTER and NIL can be used as a nonterminal symbol." + '(and symbol (not (member character nil)))) + +(deftype terminal () + "Literal strings and characters are used as case-sensitive terminal symbols, +and expressions of the form \(~ ) denote case-insensitive terminals." + `(or string character + (cons (eql ~) (cons (or string character) null)))) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..26afb85 --- /dev/null +++ b/package.lisp @@ -0,0 +1,37 @@ +(in-package #:cl-user) + +(defpackage :esrap + (:use :cl :alexandria :defmacro-enhance :iterate) + (:shadowing-import-from :rutils.string :strcat) + #+sbcl + (:lock t) + (:export + #:&bounds + + #:! #:? #:+ #:* #:& #:~ #:<- #:-> + #:character-ranges #:wrap #:tag + + #:add-rule + #:register-context + #:call-transform + #:change-rule + #:concat + #:defrule + #:describe-grammar + #:esrap-error + #:esrap-error-position + #:esrap-error-text + #:find-rule + #:left-recursion + #:left-recursion-nonterminal + #:left-recursion-path + #:parse + #:remove-rule + #:rule + #:rule-dependencies + #:rule-expression + #:rule-symbol + #:text + #:trace-rule + #:untrace-rule + )) diff --git a/rule-storage.lisp b/rule-storage.lisp new file mode 100644 index 0000000..ab217dd --- /dev/null +++ b/rule-storage.lisp @@ -0,0 +1,140 @@ +;;;; rule-storage.lisp + +(in-package :esrap) + + +;;; RULE REPRESENTATION AND STORAGE +;;; +;;; For each rule, there is a RULE-CELL in *RULES*, whose %INFO slot has the +;;; function that implements the rule in car, and the rule object in CDR. A +;;; RULE object can be attached to only one non-terminal at a time, which is +;;; accessible via RULE-SYMBOL. + +(defvar *rules* (make-hash-table)) + +(defun clear-rules () + (clrhash *rules*) + nil) + +(defstruct (rule-cell (:constructor + make-rule-cell + (symbol &aux (%info (cons (undefined-rule-function symbol) nil)))) + (:conc-name cell-)) + (%info (required-argument) :type (cons function t)) + (trace-info nil) + (referents nil :type list)) + +(declaim (inline cell-function)) +(defun cell-function (cell) + (car (cell-%info cell))) + +(defun cell-rule (cell) + (cdr (cell-%info cell))) + +(defun set-cell-info (cell function rule) + ;; Atomic update + (setf (cell-%info cell) (cons function rule)) + (let ()) + cell) + +(defun undefined-rule-function (symbol) + (lambda (&rest args) + (declare (ignore args)) + (error "Undefined rule: ~S" symbol))) + +(defun ensure-rule-cell (symbol) + (check-type symbol nonterminal) + ;; FIXME: Need to lock *RULES*. + (or (gethash symbol *rules*) + (setf (gethash symbol *rules*) + (make-rule-cell symbol)))) + +(defun delete-rule-cell (symbol) + (remhash symbol *rules*)) + +(defun reference-rule-cell (symbol referent) + (let ((cell (ensure-rule-cell symbol))) + (when referent + (pushnew referent (cell-referents cell))) + cell)) + +(defun dereference-rule-cell (symbol referent) + (let ((cell (ensure-rule-cell symbol))) + (setf (cell-referents cell) (delete referent (cell-referents cell))) + cell)) + +(defun find-rule-cell (symbol) + (check-type symbol nonterminal) + (gethash symbol *rules*)) + +(defclass rule () + ((%symbol + :initform nil) + (%expression + :initarg :expression + :initform (required-argument :expression)) + (%guard-expression + :initarg :guard-expression + :initform t + :reader rule-guard-expression) + ;; Either T for rules that are always active (the common case), + ;; NIL for rules that are never active, or a function to call + ;; to find out if the rule is active or not. + (%condition + :initarg :condition + :initform t + :reader rule-condition) + (%transform + :initarg :transform + :initform nil + :reader rule-transform) + (%around + :initarg :around + :initform nil + :reader rule-around))) + +(defun rule-symbol (rule) + "Returns the nonterminal associated with the RULE, or NIL of the rule +is not attached to any nonterminal." + (slot-value rule '%symbol)) + +(defun detach-rule (rule) + (dolist (dep (%rule-direct-dependencies rule)) + (dereference-rule-cell dep (rule-symbol rule))) + (setf (slot-value rule '%symbol) nil)) + +(defmethod shared-initialize :after ((rule rule) slots &key) + (validate-expression (rule-expression rule))) + +(defmethod print-object ((rule rule) stream) + (print-unreadable-object (rule stream :type t :identity nil) + (let ((symbol (rule-symbol rule))) + (if symbol + (format stream "~S <- " symbol) + (format stream "(detached) "))) + (write (rule-expression rule) :stream stream))) + +(defun sort-dependencies (symbol dependencies) + (let ((symbols (delete symbol dependencies)) + (defined nil) + (undefined nil)) + (dolist (sym symbols) + (if (find-rule sym) + (push sym defined) + (push sym undefined))) + (values defined undefined))) + +(defun rule-dependencies (rule) + "Returns the dependencies of the RULE: primary value is a list of defined +nonterminal symbols, and secondary value is a list of undefined nonterminal +symbols." + (sort-dependencies + (rule-symbol rule) (%expression-dependencies (rule-expression rule) nil))) + +(defun rule-direct-dependencies (rule) + (sort-dependencies + (rule-symbol rule) (%expression-direct-dependencies (rule-expression rule) nil))) + +(defun %rule-direct-dependencies (rule) + (delete (rule-symbol rule) (%expression-direct-dependencies (rule-expression rule) nil))) + From 66c221343cfddd775ae0d858533407aebe550de6 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Fri, 8 Nov 2013 04:22:07 +0400 Subject: [PATCH 17/95] First version of esrap-liquid, that passes at least some trivial tests --- esrap.asd | 52 +- esrap.lisp | 1276 ------------------------ memoization.lisp | 53 - package.lisp | 37 - rule-storage.lisp | 140 --- src/basic-rules.lisp | 38 + conditions.lisp => src/conditions.lisp | 6 +- src/esrap.lisp | 56 ++ src/macro.lisp | 153 +++ src/macro.lisp~ | 144 +++ src/memoization.lisp | 60 ++ miscellany.lisp => src/miscellany.lisp | 6 +- src/package.lisp | 21 + src/rule-storage.lisp | 23 + tests.lisp | 371 ------- tests/package.lisp | 22 + tests/rules.lisp | 205 ++++ tests/tests.lisp | 189 ++++ 18 files changed, 947 insertions(+), 1905 deletions(-) delete mode 100644 esrap.lisp delete mode 100644 memoization.lisp delete mode 100644 package.lisp delete mode 100644 rule-storage.lisp create mode 100644 src/basic-rules.lisp rename conditions.lisp => src/conditions.lisp (97%) create mode 100644 src/esrap.lisp create mode 100644 src/macro.lisp create mode 100644 src/macro.lisp~ create mode 100644 src/memoization.lisp rename miscellany.lisp => src/miscellany.lisp (95%) create mode 100644 src/package.lisp create mode 100644 src/rule-storage.lisp delete mode 100644 tests.lisp create mode 100644 tests/package.lisp create mode 100644 tests/rules.lisp create mode 100644 tests/tests.lisp diff --git a/esrap.asd b/esrap.asd index 26f78f9..abccd07 100644 --- a/esrap.asd +++ b/esrap.asd @@ -1,20 +1,9 @@ -;;;; Copyright (c) 2007-2013 Nikodemus Siivola -;;;; -;;;; Permission is hereby granted, free of charge, to any person -;;;; obtaining a copy of this software and associated documentation files -;;;; (the "Software"), to deal in the Software without restriction, -;;;; including without limitation the rights to use, copy, modify, merge, -;;;; publish, distribute, sublicense, and/or sell copies of the Software, -;;;; and to permit persons to whom the Software is furnished to do so, -;;;; subject to the following conditions: -;;;; -;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +;;;; A packrat parser, implemented without duplication of common lisp code-walker. + +;;;; Heavily based on initial work of Nikodemus Siivola (https://github.com/nikodemus/esrap) +;;;; Most of the code is, however, rewritten. + +;;;; For licence details, see COPYING (defpackage :esrap-system (:use :cl :asdf)) @@ -24,22 +13,33 @@ (defsystem :esrap :version "1.1" ; odd minor version numbers are for unstable versions :description "A Packrat / Parsing Grammar / TDPL parser for Common Lisp." - :licence "MIT" - :depends-on (:alexandria :defmacro-enhance :iterate :rutils :cl-indeterminism) + :licence "GPL" + :depends-on (:alexandria :defmacro-enhance :iterate :rutils :cl-indeterminism :cl-read-macro-tokens) :serial t - :components ((:file "package") - (:file "conditions") - (:file "miscellany") - (:file "esrap") + :components ((:module "src" + :pathname "src/" + :serial t + :components ((:file "package") + (:file "conditions") + (:file "miscellany") + (:file "memoization") + (:file "rule-storage") + (:file "macro") + (:file "esrap") + (:file "basic-rules"))) (:static-file "example-sexp.lisp") (:static-file "example-symbol-table.lisp") (:static-file "README"))) (defsystem :esrap-tests :description "Tests for ESRAP." - :licence "MIT" - :depends-on (:esrap :fiveam) - :components ((:file "tests"))) + :licence "GPL" + :depends-on (#:esrap #:fiveam #:cl-interpol) + :serial t + :pathname "tests/" + :components ((:file "package") + (:file "rules") + (:file "tests"))) (defmethod perform ((op test-op) (sys (eql (find-system :esrap)))) (load-system :esrap-tests) diff --git a/esrap.lisp b/esrap.lisp deleted file mode 100644 index 5416fe1..0000000 --- a/esrap.lisp +++ /dev/null @@ -1,1276 +0,0 @@ -;;;; ESRAP -- a packrat parser for Common Lisp -;;;; by Nikodemus Siivola, 2007-2012 -;;;; -;;;; Homepage and documentation: -;;;; -;;;; http://nikodemus.github.com/esrap/ -;;;; -;;;; References: -;;;; -;;;; * Bryan Ford, 2002, "Packrat Parsing: a Practical Linear Time -;;;; Algorithm with Backtracking". -;;;; http://pdos.csail.mit.edu/~baford/packrat/thesis/ -;;;; -;;;; Licence: -;;;; -;;;; Permission is hereby granted, free of charge, to any person -;;;; obtaining a copy of this software and associated documentation files -;;;; (the "Software"), to deal in the Software without restriction, -;;;; including without limitation the rights to use, copy, modify, merge, -;;;; publish, distribute, sublicense, and/or sell copies of the Software, -;;;; and to permit persons to whom the Software is furnished to do so, -;;;; subject to the following conditions: -;;;; -;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -(in-package :esrap) - - -;;; Expression destructuring and validation - -;;; TODO: Probably this won't be needed, once liquification is complete -(defmacro with-expression ((expr lambda-list) &body body) - (let* ((type (car lambda-list)) - (car-var (gensym "CAR")) - (fixed-list (cons car-var (cdr lambda-list)))) - (once-only (expr) - `(destructuring-bind ,fixed-list ,expr - ,(if (eq t type) - `(declare (ignore ,car-var)) - `(unless (eq ',type ,car-var) - (error "~S-expression expected, got: ~S" ',type ,expr))) - (locally ,@body))))) - - -;;; RESULT REPRESENTATION -;;; -;;; We always return a result -- ERROR-RESULT for failed parses, and -;;; RESULT for successes. -;;; -;;; We implement a simple lazy evaluation for the productions. This is -;;; used to perform semantic actions only when necessary -- either -;;; when we call a semantic predicate or once parse has finished. - -(defstruct error-result) - -(defstruct (inactive-rule (:include error-result)) - name) - -(defstruct (failed-parse (:include error-result)) - ;; Expression that failed to match. - expression - ;; Position at which match was attempted. - (position (required-argument) :type array-index) - ;; A nested error, closer to actual failure site. - detail) - -(defstruct (result (:constructor %make-result)) - ;; Either a list of results, whose first element is the production, or a - ;; function to call that will return the production. - %production - ;; Position after the match. - (position (required-argument) :type array-index)) - -(defmacro make-result (&rest arguments &key production &allow-other-keys) - (if production - (let ((args (copy-list arguments))) - (remf args :production) - `(%make-result ,@args - :%production ,(if (symbolp production) - `(list ,production) - `(lambda () ,production)))) - `(%make-result ,@arguments))) - -(defun result-production (result) - (let ((thunk (result-%production result))) - (if (functionp thunk) - (let ((value (funcall thunk))) - (setf (result-%production result) (list value)) - value) - (car thunk)))) - -;;; MAIN INTERFACE - -(defun parse (expression text &key (start 0) end junk-allowed) - "Parses TEXT using EXPRESSION from START to END. Incomplete parses -are allowed only if JUNK-ALLOWED is true." - ;; There is no backtracking in the toplevel expression -- so there's - ;; no point in compiling it as it will be executed only once -- unless - ;; it's a constant, for which we have a compiler-macro. - (let ((end (or end (length text)))) - (process-parse-result - (let ((*cache* (make-cache))) - (eval-expression expression text start end)) - text - end - junk-allowed))) - -;; (define-compiler-macro parse (&whole form expression &rest arguments -;; &environment env) -;; (if (constantp expression env) -;; (with-gensyms (expr-fun) -;; `(let ((,expr-fun (load-time-value (compile-expression ,expression)))) -;; ;; This inline-lambda here provides keyword defaults and -;; ;; parsing, so the compiler-macro doesn't have to worry -;; ;; about evaluation order. -;; ((lambda (text &key (start 0) end junk-allowed) -;; (let ((*cache* (make-cache)) -;; (end (or end (length text)))) -;; (process-parse-result -;; (funcall ,expr-fun text start end) -;; text -;; end -;; junk-allowed))) -;; ,@arguments))) -;; form)) - -(defun process-parse-result (result text end junk-allowed) - (if (error-result-p result) - (if junk-allowed - (values nil 0) - (if (failed-parse-p result) - (labels ((expressions (e) - (when e - (cons (failed-parse-expression e) - (expressions (failed-parse-detail e)))))) - (let ((expressions (expressions result))) - (simple-esrap-error text (failed-parse-position result) - "Could not parse subexpression ~S when ~ - parsing~2&~< Expression ~S~@{~& ~ - Subexpression ~S~}~:>" - (lastcar expressions) - expressions))) - (simple-esrap-error text nil "rule ~S not active" - (inactive-rule-name result)))) - (let ((position (result-position result))) - (values (result-production result) - (when (< position end) - (if junk-allowed - position - (simple-esrap-error text position "Incomplete parse."))))))) - -(defmacro! defrule (&whole form symbol expression check) - "Define SYMBOL as a nonterminal, using EXPRESSION as associated the parsing expression. -Rule is only succeeds, if CHECK evaluates to true." - (let ((transform nil) - (around nil) - (guard t) - (condition t) - (guard-seen nil)) - (when options - (dolist (option options) - (flet ((set-transform (trans) - (if transform - (error "Multiple transforms in DEFRULE:~% ~S" form) - (setf transform trans))) - (set-guard (expr test) - (if guard-seen - (error "Multiple guards in DEFRULE:~% ~S" form) - (setf guard-seen t - guard expr - condition test)))) - (destructuring-ecase option - ((:when expr) - (when (cddr option) - (error "Multiple expressions in a :WHEN:~% ~S" form)) - (if (constantp expr) - (if (eval expr) - (set-guard expr t) - (set-guard expr nil)) - (set-guard expr `(lambda () ,expr)))) - ((:constant value) - (setf transform `(constantly ,value))) - ((:concat value) - (note-deprecated :concat :text) - (when value - (setf transform '#'text/bounds))) - ((:text value) - (when value - (setf transform '#'text/bounds))) - ((:identity value) - (when value - (setf transform '#'identity/bounds))) - ((:lambda lambda-list &body forms) - (multiple-value-bind (lambda-list start end ignore) - (parse-lambda-list-maybe-containing-&bounds lambda-list) - (setf transform - `(lambda (,@lambda-list ,start ,end) - (declare (ignore ,@ignore)) - ,@forms)))) - ((:function designator) - (setf transform `(lambda/bounds (function ,designator)))) - ((:destructure lambda-list &body forms) - (multiple-value-bind (lambda-list start end ignore) - (parse-lambda-list-maybe-containing-&bounds lambda-list) - (setf transform - (with-gensyms (production) - `(lambda (,production ,start ,end) - (declare (ignore ,@ignore)) - (destructuring-bind ,lambda-list ,production - ,@forms)))))) - ((:around lambda-list &body forms) - (multiple-value-bind (lambda-list start end ignore) - (parse-lambda-list-maybe-containing-&bounds lambda-list) - (assert (null lambda-list)) - (setf around `(lambda (,start ,end transform) - (declare (ignore ,@ignore) - (function transform)) - (flet ((call-transform () - (funcall transform))) - ,@forms))))) - ((:wrap-around &body forms) - (setf around `(lambda (,e!-wrapper ,e!-parser) ; should change to g!-syms here - (declare (ignorable ,e!-wrapper ,e!-parser)) - (flet ((,e!-call-parser () - (funcall ,e!-parser))) - ,@forms)))))))) - `(eval-when (:load-toplevel :execute) - (add-rule ',symbol (make-instance 'rule - :expression ',expression - :guard-expression ',guard - :transform ,(or transform '#'identity/bounds) - :around ,around - :condition ,condition))))) - -(defun add-rule (symbol rule) - "Associates RULE with the nonterminal SYMBOL. Signals an error if the -rule is already associated with a nonterminal. If the symbol is already -associated with a rule, the old rule is removed first." - ;; FIXME: This needs locking and WITHOUT-INTERRUPTS. - (check-type symbol nonterminal) - (when (rule-symbol rule) - (error "~S is already associated with the nonterminal ~S -- remove it first." - rule (rule-symbol rule))) - (let* ((cell (ensure-rule-cell symbol)) - (function (compile-rule symbol - (rule-expression rule) - (rule-condition rule) - (rule-transform rule) - (rule-around rule))) - (function (lambda (text position end) - (funcall function text position end))) - (trace-info (cell-trace-info cell))) - (set-cell-info cell function rule) - (setf (cell-trace-info cell) nil) - (setf (slot-value rule '%symbol) symbol) - (when trace-info - (trace-rule symbol :break (second trace-info))) - symbol)) - -(defun find-rule (symbol) - "Returns rule designated by SYMBOL, if any. Symbol must be a nonterminal -symbol." - (check-type symbol nonterminal) - (let ((cell (find-rule-cell symbol))) - (when cell - (cell-rule cell)))) - -(defun remove-rule (symbol &key force) - "Makes the nonterminal SYMBOL undefined. If the nonterminal is defined an -already referred to by other rules, an error is signalled unless :FORCE is -true." - (check-type symbol nonterminal) - ;; FIXME: Lock and WITHOUT-INTERRUPTS. - (let* ((cell (find-rule-cell symbol)) - (rule (cell-rule cell)) - (trace-info (cell-trace-info cell))) - (when cell - (flet ((frob () - (set-cell-info cell (undefined-rule-function symbol) nil) - (when trace-info - (setf (cell-trace-info cell) (list (cell-%info cell) (second trace-info)))) - (when rule - (detach-rule rule)))) - (cond ((and rule (cell-referents cell)) - (unless force - (error "Nonterminal ~S is used by other nonterminal~P:~% ~{~S~^, ~}" - symbol (length (cell-referents cell)) (cell-referents cell))) - (frob)) - ((not (cell-referents cell)) - (frob) - ;; There are no references to the rule at all, so - ;; we can remove the cell. - (unless trace-info - (delete-rule-cell symbol))))) - rule))) - -(defvar *trace-level* 0) - -(defvar *trace-stack* nil) - -(defun trace-rule (symbol &key recursive break) - "Turn on tracing of nonterminal SYMBOL. If RECURSIVE is true, turn -on tracing for the whole grammar rooted at SYMBOL. If BREAK is true, -break is entered when the rule is invoked." - (unless (member symbol *trace-stack* :test #'eq) - (let ((cell (find-rule-cell symbol))) - (unless cell - (error "Undefined rule: ~S" symbol)) - (when (cell-trace-info cell) - (let ((*trace-stack* nil)) - (untrace-rule symbol))) - (let ((fun (cell-function cell)) - (rule (cell-rule cell)) - (info (cell-%info cell))) - (set-cell-info cell - (lambda (text position end) - (when break - (break "rule ~S" symbol)) - (let ((space (make-string *trace-level* :initial-element #\space)) - (*trace-level* (+ 1 *trace-level*))) - (format *trace-output* "~&~A~D: ~S ~S? ~%" - space *trace-level* symbol position) - (finish-output *trace-output*) - (let ((result (funcall fun text position end))) - (if (error-result-p result) - (format *trace-output* "~&~A~D: ~S -|~%" - space *trace-level* symbol) - (format *trace-output* "~&~A~D: ~S ~S-~S -> ~S~%" - space *trace-level* symbol - position - (result-position result) - (result-production result))) - (finish-output *trace-output*) - result))) - rule) - (setf (cell-trace-info cell) (list info break))) - (when recursive - (let ((*trace-stack* (cons symbol *trace-stack*))) - (dolist (dep (%rule-direct-dependencies (cell-rule cell))) - (trace-rule dep :recursive t :break break)))) - t))) - -(defun untrace-rule (symbol &key recursive break) - "Turn off tracing of nonterminal SYMBOL. If RECURSIVE is true, untraces the -whole grammar rooted at SYMBOL. BREAK is ignored, and is provided only for -symmetry with TRACE-RULE." - (declare (ignore break)) - (unless (member symbol *trace-stack* :test #'eq) - (let ((cell (find-rule-cell symbol))) - (unless cell - (error "Undefined rule: ~S" symbol)) - (let ((trace-info (cell-trace-info cell))) - (when trace-info - (setf (cell-%info cell) (car trace-info) - (cell-trace-info cell) nil)) - (when recursive - (let ((*trace-stack* (cons symbol *trace-stack*))) - (dolist (dep (%rule-direct-dependencies (cell-rule cell))) - (untrace-rule dep :recursive t)))))) - nil)) - -(defun rule-expression (rule) - "Return the parsing expression associated with the RULE." - (slot-value rule '%expression)) - -(defun (setf rule-expression) (expression rule) - "Modify RULE to use EXPRESSION as the parsing expression. The rule must be -detached beforehand." - (let ((name (rule-symbol rule))) - (when name - (error "~@" - name)) - (setf (slot-value rule '%expression) expression))) - -(defun change-rule (symbol expression) - "Modifies the nonterminal SYMBOL to use EXPRESSION instead. Temporarily -removes the rule while it is being modified." - (let ((rule (remove-rule symbol :force t))) - (unless rule - (error "~S is not a defined rule." symbol)) - (setf (rule-expression rule) expression) - (add-rule symbol rule))) - -(defun symbol-length (x) - (length (symbol-name x))) - -(defun describe-grammar (symbol &optional (stream *standard-output*)) - "Prints the grammar tree rooted at nonterminal SYMBOL to STREAM for human -inspection." - (check-type symbol nonterminal) - (let ((rule (find-rule symbol))) - (cond ((not rule) - (format stream "Symbol ~S is not a defined nonterminal." symbol)) - (t - (format stream "~&Grammar ~S:~%" symbol) - (multiple-value-bind (defined undefined) (rule-dependencies rule) - (let ((length - (+ 4 (max (reduce #'max (mapcar #'symbol-length defined) - :initial-value 0) - (reduce #'max (mapcar #'symbol-length undefined) - :initial-value 0))))) - (format stream "~3T~S~VT<- ~S~@[ : ~S~]~%" - symbol length (rule-expression rule) - (when (rule-condition rule) - (rule-guard-expression rule))) - (when defined - (dolist (s defined) - (let ((dep (find-rule s))) - (format stream "~3T~S~VT<- ~S~@[ : ~S~]~%" - s length (rule-expression dep) - (when (rule-condition rule) - (rule-guard-expression rule)))))) - (when undefined - (format stream "~%Undefined nonterminal~P:~%~{~3T~S~%~}" - (length undefined) undefined)))))))) - -;;; COMPILING RULES - -(defvar *current-rule* nil) - -(defun compile-rule (symbol expression condition transform around) - (declare (type (or boolean function) condition transform around)) - (macrolet ((cur-parse-failed (&optional (result-var 'result)) - `(make-failed-parse - :expression symbol - :position (if (failed-parse-p ,result-var) - (failed-parse-position ,result-var) - position) - :detail ,result-var)) - (call-transform (&optional (result-var 'result)) - `(funcall transform - (result-production ,result-var) - position - (result-position ,result-var))) - (conditionally-exec (name &body body) - `(if (eq t condition) - (named-lambda ,name (text position end) - (with-cached-result (symbol position text) - ,@body)) - (named-lambda ,(intern (strcat "CONDITIONAL-" name)) (text position end) - (with-cached-result (symbol position text) - (if (funcall condition) - (progn ,@body) - rule-not-active))))) - (make-result-evenly (result-var &optional (production '(call-transform))) - `(make-result :position (result-position ,result-var) - :production ,production))) - (let ((*current-rule* symbol)) - ;; Must bind *CURRENT-RULE* before compiling the expression! - (if (and (consp expression) - (symbolp (car expression)) - (equal (string (car expression)) "WRAP")) - (destructuring-bind (wrap wrapper wrappie) expression - (declare (ignore wrap)) - (let* ((func-wrapper (compile-expression wrapper)) - (rule-not-active (when condition (make-inactive-rule :name symbol)))) - (cond ((not condition) - (named-lambda inactive-rule (text position end) - (declare (ignore text position end)) - rule-not-active)) - ((not (and transform around)) - (error "When specifying WRAP rule both TRANSFORM and AROUND should be present.")) - (t (flet ((exec-rule/wrap (text position end) - (let ((wrapper-result (funcall func-wrapper text position end))) - (if (error-result-p wrapper-result) - (cur-parse-failed wrapper-result) - (funcall around - (result-production wrapper-result) - (lambda () - (let* ((func-wrappie (compile-expression wrappie)) - (wrappie-result (funcall func-wrappie text - (result-position wrapper-result) - end))) - (if (error-result-p wrappie-result) - (cur-parse-failed wrappie-result) - (let ((production (call-transform wrappie-result))) - (make-result-evenly wrappie-result - (values production))))))))))) - (conditionally-exec rule/wrap - (exec-rule/wrap text position end))))))) - (let* ((function (compile-expression expression)) - (rule-not-active (when condition (make-inactive-rule :name symbol)))) - (cond ((not condition) - (named-lambda inactive-rule (text position end) - (declare (ignore text position end)) - rule-not-active)) - (transform - (flet ((exec-rule/transform (text position end) - (let ((result (funcall function text position end))) - (if (error-result-p result) - (cur-parse-failed) - (if around - (make-result-evenly result - (flet ((call-rule () - (call-transform))) - (funcall around - position - (result-position result) - #'call-rule))) - (make-result-evenly result)))))) - (conditionally-exec rule/transform - (exec-rule/transform text position end)))) - (t (conditionally-exec rule - (funcall function text position end))))))))) - -;;; EXPRESSION COMPILER & EVALUATOR - -(defun invalid-expression-error (expression) - (error "Invalid expression: ~S" expression)) - -(defun validate-character-range (range) - (or - (characterp range) - (and - (consp range) - (consp (cdr range)) - (characterp (car range)) - (characterp (cadr range)) - (null (cddr range))))) - -(defun validate-expression (expression) - (or (typecase expression - ((eql character) - t) - (terminal - t) - (nonterminal - t) - (cons - (case (car expression) - ((and or wrap) - (and (every #'validate-expression (cdr expression)) t)) - ((nil) - nil) - (string - (and (cdr expression) (not (cddr expression)) - (typep (second expression) 'array-length))) - (character-ranges - (and (every #'validate-character-range (cdr expression)) t)) - (* (and (>= (length expression) 2) - (validate-expression (car (last expression))))) - (cond (and (every (lambda (x) - (and (every #'validate-expression x) t)) - (cdr expression)) - t)) - (tag (and (equal (length expression) 3) - (keywordp (cadr expression)) - (validate-expression (caddr expression)))) - (t - (and (symbolp (car expression)) - (cdr expression) (not (cddr expression)) - (validate-expression (second expression)))))) - (t - nil)) - (invalid-expression-error expression))) - -(defun %expression-dependencies (expression seen) - (etypecase expression - ((member character) - seen) - (terminal - seen) - (nonterminal - (if (member expression seen :test #'eq) - seen - (let ((rule (find-rule expression)) - (seen (cons expression seen))) - (if rule - (%expression-dependencies (rule-expression rule) seen) - seen)))) - (cons - (case (car expression) - ((string character-ranges) - seen) - ((and or) - (dolist (subexpr (cdr expression) seen) - (setf seen (%expression-dependencies subexpr seen)))) - ((* + ? & !) - (%expression-dependencies (second expression) seen)) - (t - (%expression-dependencies (second expression) seen)))))) - -(defun %expression-direct-dependencies (expression seen) - (etypecase expression - ((member character) - seen) - (terminal - seen) - (nonterminal - (cons expression seen)) - (cons - (case (car expression) - (string - seen) - ((and or) - (dolist (subexpr (cdr expression) seen) - (setf seen (%expression-direct-dependencies subexpr seen)))) - ((* + ? & !) - (%expression-direct-dependencies (second expression) seen)) - (t - (%expression-direct-dependencies (second expression) seen)))))) - -(defun eval-expression (expression text position end) - (macrolet ((frob ((&rest clauses) &body body) - `(case (car expression) - ,@(mapcar (lambda (clause) - (let ((clause (if (atom clause) `(,clause) clause))) - `(,(car clause) (,(sb-int:symbolicate "EVAL-" (or (cadr clause) (car clause))) - expression text position end)))) - clauses) - ,@body))) - (typecase expression - ((eql character) - (eval-character text position end)) - (terminal - (if (consp expression) - (eval-terminal (string (second expression)) text position end nil) - (eval-terminal (string expression) text position end t))) - (nonterminal - (eval-nonterminal expression text position end)) - (cons - (frob (string (and sequence) (or ordered-choice) (not negation) - (+ greedy-positive-repetition) (? optional) (& followed-by) (-> followed-by-not-gen) - (<- preceded-by-not-gen) (! not-followed-by) character-ranges cond first tag) - (* (cond ((equal (length expression) 2) (eval-greedy-repetition expression text position end)) - (t (eval-times expression text position end)))) - (t - (if (symbolp (car expression)) - (eval-semantic-predicate expression text position end) - (invalid-expression-error expression))))) - (t - (invalid-expression-error expression))))) - -(defun compile-expression (expression) - (macrolet ((frob ((&rest clauses) &body body) - `(case (car expression) - ,@(mapcar (lambda (clause) - (let ((clause (if (atom clause) `(,clause) clause))) - `(,(car clause) (,(sb-int:symbolicate "COMPILE-" (or (cadr clause) (car clause))) - expression)))) - clauses) - ,@body))) - (etypecase expression - ((eql character) - (compile-character)) - (terminal - (if (consp expression) - (compile-terminal (string (second expression)) nil) - (compile-terminal (string expression) t))) - (nonterminal - (compile-nonterminal expression)) - (cons - (frob (string (and sequence) (or ordered-choice) (not negation) - (+ greedy-positive-repetition) (? optional) (& followed-by) (-> followed-by-not-gen) - (<- preceded-by-not-gen) (! not-followed-by) character-ranges cond first tag) - (* (cond ((equal (length expression) 2) (compile-greedy-repetition expression)) - (t (compile-times expression)))) - (t - (if (symbolp (car expression)) - (compile-semantic-predicate expression) - (invalid-expression-error expression))))) - (t - (invalid-expression-error expression))))) - -;;; Characters and strings - -(defmacro! any-string (length) - (let ((expression '(any-string ,length)) - (limit (+ ,length position))) - (if (<= limit end) - (make-result - :production (subseq text position limit) - :position limit) - (fail "Unable to parse any string of specified length.")))) - -(define-symbol-macro character - (let ((expression 'character)) - (if (< position end) - (make-result - :production (char text position) - :position (1+ position)) - (fail "EOF reached while trying to parse character.")))) - - -;;; Terminals -;;; -;;; FIXME: It might be worth it to special-case terminals of length 1. - -;;; #]foo[ denotes literal string terminal "foo" -(set-dispatch-macro-character #\# #\] - (lambda (stream subchar arg) - (declare (ignore subchar arg)) - `(terminal ,(sb-impl::read-string stream #\[) nil))) - -(set-dispatch-macro-character #\# #\/ (let ((f (get-dispatch-macro-character #\# #\\))) - (lambda (stream subchar arg) - (let ((char (funcall f stream subchar arg))) - `(terminal ,char nil))))) - -(defmacro terminal (terminal case-insensitive) - (let ((length (length terminal)) - (terminal (string terminal))) - `(if (and (<= (+ ,length position) end) - ,(if case-insensitive - `(string-equal ,terminal text :start2 position :end2 (+ position ,length)) - `(string= ,terminal text :start2 position :end2 (+ position ,length)))) - (make-result - :position (+ ,length position) - :production '(terminal ,terminal)) - (fail)))) - -(defmacro! ~ (terminal) - "Expands into case-insensitive terminal checking." - `(terminal ,terminal t)) - -;;; Nonterminals - -(defparameter *eval-nonterminals* nil) - -(defun eval-nonterminal (symbol text position end) - (if *eval-nonterminals* - (eval-expression (rule-expression (find-rule symbol)) text position end) - (funcall (cell-function (ensure-rule-cell symbol)) text position end))) - -(defun compile-nonterminal (symbol) - (let ((cell (reference-rule-cell symbol *current-rule*))) - (declare (rule-cell cell)) - (named-lambda compile-nonterminal (text position end) - (funcall (cell-function cell) text position end)))) - -;;; Sequences -;;; -;;; FIXME: It might be better if we actually chained the closures -;;; here, instead of looping over them -- benchmark first, though. - -(defmacro! fail (detail) - `(error 'parse-error - :expression expression - :position position - :detail ,detail)) - - -(defmacro! && (&rest subexpressions) - `(let ((,g!-subexprs (list ,@(mapcar (lambda (x) `(lambda () - (let ((expression ',x)) - ,x)) - subexpressions))))) - (iter (for ,g!-subexpr in ,g!-subexprs) - (let ((,g!-result (funcall ,g!-subexpr))) - (if (error-result-p ,g!-result) - (fail ,g!-result) - (progn (setf position (result-position ,g!-result)) - (collect (result-production ,g!-result)))))))) - -;;; Ordered choices - -(defun eval-ordered-choice (expression text position end) - (with-expression (expression (or &rest subexprs)) - (let (last-error) - (dolist (expr subexprs - (make-failed-parse - :expression expression - :position (if (failed-parse-p last-error) - (failed-parse-position last-error) - position) - :detail last-error)) - (let ((result (eval-expression expr text position end))) - (if (error-result-p result) - (when (or (and (not last-error) - (or (inactive-rule-p result) - (< position (failed-parse-position result)))) - (and last-error - (failed-parse-p result) - (or (inactive-rule-p last-error) - (< (failed-parse-position last-error) - (failed-parse-position result))))) - (setf last-error result)) - (return result))))))) - -(defun compile-ordered-choice (expression) - (with-expression (expression (or &rest subexprs)) - (let ((type :characters) - (canonized nil)) - (dolist (sub subexprs) - (when (typep sub '(or character string)) - (let* ((this (string sub)) - (len (length this))) - (unless (some (lambda (seen) - (not - ;; Check for "FOO" followed by "FOOBAR" -- the - ;; latter would never match, but it's an easy mistake to make. - (or (mismatch this seen :end1 (min (length seen) len)) - (warn "Prefix ~S before ~S in an ESRAP OR expression." - seen this)))) - canonized) - (push this canonized)))) - (case type - (:general) - (:strings - (unless (typep sub '(or character string)) - (setf type :general))) - (:characters - (unless (typep sub '(or character (string 1))) - (if (typep sub 'string) - (setf type :strings) - (setf type :general)))))) - ;; FIXME: Optimize case-insensitive terminals as well. - (ecase type - (:characters - ;; If every subexpression is a length 1 string, we can represent the whole - ;; choice with a single string. - (let ((choices (apply #'concatenate 'string canonized))) - (named-lambda compiled-character-choice (text position end) - (let ((c (and (< position end) (find (char text position) choices)))) - (if c - (make-result :position (+ 1 position) - :production (string c)) - (make-failed-parse - :expression expression - :position position)))))) - (:strings - ;; If every subexpression is a string, we can represent the whole choice - ;; with a list of strings. - (let ((choices (nreverse canonized))) - (named-lambda compiled-character-choice (text position end) - (dolist (choice choices - (make-failed-parse - :expression expression - :position position)) - (let ((len (length choice))) - (when (match-terminal-p choice len text position end t) - (return - (make-result :position (+ len position) - :production choice)))))))) - (:general - ;; In the general case, compile subexpressions and call. - (let ((functions (mapcar #'compile-expression subexprs))) - (named-lambda compiled-ordered-choice (text position end) - (let (last-error) - (dolist (fun functions - (make-failed-parse - :expression expression - :position (if (and last-error - (failed-parse-p last-error)) - (failed-parse-position last-error) - position) - :detail last-error)) - (let ((result (funcall fun text position end))) - (if (error-result-p result) - (when (or (and (not last-error) - (or (inactive-rule-p result) - (< position (failed-parse-position result)))) - (and last-error - (failed-parse-p result) - (or (inactive-rule-p last-error) - (< (failed-parse-position last-error) - (failed-parse-position result))))) - (setf last-error result)) - (return result)))))))))))) - -;;; Negations - -(defun exec-negation (fun expr text position end) - (if (and (< position end) - (error-result-p (funcall fun text position end))) - (make-result - :position (1+ position) - :production (char text position)) - (make-failed-parse - :expression expr - :position position))) - -(defun eval-negation (expression text position end) - (with-expression (expression (not subexpr)) - (flet ((eval-sub (text position end) - (eval-expression subexpr text position end))) - (declare (dynamic-extent #'eval-sub)) - (exec-negation #'eval-sub expression text position end)))) - -(defun compile-negation (expression) - (with-expression (expression (not subexpr)) - (let ((sub (compile-expression subexpr))) - (named-lambda compiled-negation (text position end) - (exec-negation sub expression text position end))))) - -;;; On-the-fly tagging -(defun eval-tag (expression text position end) - (funcall (compile-tag expression) text position end)) - -(defun compile-tag (expression) - (with-expression (expression (tag keyword subexpr)) - (let ((function (compile-expression subexpr))) - (named-lambda compiled-tag (text position end) - (let ((result (funcall function text position end))) - (if (error-result-p result) - result - (make-result - :position (result-position result) - :production `(,keyword ,(result-production result))))))))) - -;;; Greedy repetitions - -(defun eval-greedy-repetition (expression text position end) - (funcall (compile-greedy-repetition expression) text position end)) - -(defun compile-greedy-repetition (expression) - (with-expression (expression (* subexpr)) - (let ((function (compile-expression subexpr))) - (named-lambda compiled-greedy-repetition (text position end) - (let ((results - (iter (for result next (funcall function text position end)) - (until (or (error-result-p result) - (if-first-time nil - (equal (result-position result) position)))) - (setf position (result-position result)) - (collect result)))) - (make-result - :position position - :production (mapcar #'result-production results))))))) - -(defun eval-times (expression text position end) - (funcall (compile-times expression) text position end)) - -(defun compile-times (expression) - (destructuring-bind (from to subexpr) - (if (equal (length expression) 3) - `(0 ,@(cdr expression)) - (cdr expression)) - (let ((evallee `(let ((function (compile-expression ',subexpr))) - (named-lambda compiled-times (text position end) - (let* ((last nil) - (results - (iter ,@(if to `((for i from 1 to ,to))) - (for result next (funcall function text position end)) - (until (or (error-result-p (setf last result)) - (if-first-time nil - (equal (result-position result) position)))) - (setf position (result-position result)) - (collect result)))) - (if (>= (length results) ,from) - (make-result - :position position - :production (mapcar #'result-production results)) - (make-failed-parse - :position position - :expression ',expression - :detail last))))))) - (eval evallee)))) - - -;;; Greedy positive repetitions - -(defun eval-greedy-positive-repetition (expression text position end) - (funcall (compile-greedy-positive-repetition expression) - text position end)) - -(defun compile-greedy-positive-repetition (expression) - (with-expression (expression (+ subexpr)) - (let ((function (compile-expression subexpr))) - (named-lambda compiled-greedy-positive-repetition (text position end) - (let* ((last nil) - (results - (iter (for result next (funcall function text position end)) - (until (or (error-result-p (setf last result)) - (if-first-time nil - (equal (result-position result) position)))) - (setf position (result-position result)) - (collect result)))) - (if results - (make-result - :position position - :production (mapcar #'result-production results)) - (make-failed-parse - :position position - :expression expression - :detail last))))))) - -;;; Optionals - -(defun eval-optional (expression text position end) - (with-expression (expression (? subexpr)) - (let ((result (eval-expression subexpr text position end))) - (if (error-result-p result) - (make-result :position position) - result)))) - -(defun compile-optional (expression) - (with-expression (expression (? subexpr)) - (let ((function (compile-expression subexpr))) - (named-lambda compiled-optional (text position end) - (let ((result (funcall function text position end))) - (if (error-result-p result) - (make-result :position position) - result)))))) - -;;; Followed-by's - -(defun eval-followed-by (expression text position end) - (with-expression (expression (& subexpr)) - (let ((result (eval-expression subexpr text position end))) - (if (error-result-p result) - (make-failed-parse - :position position - :expression expression - :detail result) - (make-result - :position position - :production (result-production result)))))) - -(defun compile-followed-by (expression) - (with-expression (expression (& subexpr)) - (let ((function (compile-expression subexpr))) - (named-lambda compiled-followed-by (text position end) - (let ((result (funcall function text position end))) - (if (error-result-p result) - (make-failed-parse - :position position - :expression expression - :detail result) - (make-result - :position position - :production (result-production result)))))))) - -;;; Followed-by-not-gen's - -(defun eval-followed-by-not-gen (expression text position end) - (with-expression (expression (-> subexpr)) - (let ((result (if (and (symbolp subexpr) (equal (string subexpr) "EOF")) - (if (equal position end) - (make-result :position position) - (make-failed-parse :expression subexpr :position position)) - (eval-expression subexpr text position end)))) - (if (error-result-p result) - (make-failed-parse - :position position - :expression expression - :detail result) - (make-result - :position position))))) - -(defun compile-followed-by-not-gen (expression) - (with-expression (expression (-> subexpr)) - (let ((function (if (and (symbolp subexpr) (equal (string subexpr) "EOF")) - (lambda (text position end) - (declare (ignore text)) - (if (equal position end) - (make-result :position position) - (make-failed-parse :expression subexpr :position position))) - (compile-expression subexpr)))) - (named-lambda compiled-followed-by-not-gen (text position end) - (let ((result (funcall function text position end))) - (if (error-result-p result) - (make-failed-parse - :position position - :expression expression - :detail result) - (make-result - :position position))))))) - -;;; Not followed-by's - -(defun eval-not-followed-by (expression text position end) - (with-expression (expression (! subexpr)) - (let ((result (eval-expression subexpr text position end))) - (if (error-result-p result) - (make-result - :position position) - (make-failed-parse - :expression expression - :position position))))) - -(defun compile-not-followed-by (expression) - (with-expression (expression (! subexpr)) - (let ((function (compile-expression subexpr))) - (named-lambda compiled-not-followed-by (text position end) - (let ((result (funcall function text position end))) - (if (error-result-p result) - (make-result - :position position) - (make-failed-parse - :expression expression - :position position))))))) - -;;; Preceded-by's - -(defun eval-preceded-by-not-gen (expression text position end) - (with-expression (expression (<- subexpr)) - (let ((result (if (and (symbolp subexpr) (equal (string subexpr) "SOF")) - (if (equal position 0) - (make-result :position position) - (make-failed-parse :expression subexpr :position position)) - (eval-expression subexpr text (1- position) end)))) - (if (or (error-result-p result) (not (equal (result-position result) position))) - (make-failed-parse - :position position - :expression expression - :detail result) - (make-result - :position position))))) - -(defun compile-preceded-by-not-gen (expression) - (with-expression (expression (<- subexpr)) - (let ((function (if (and (symbolp subexpr) (equal (string subexpr) "SOF")) - (lambda (text position end) - (declare (ignore text end)) - (if (equal position -1) - (make-result :position 0) - (make-failed-parse :expression subexpr :position position))) - (compile-expression subexpr)))) - (named-lambda compiled-preceded-by-not-gen (text position end) - (let ((result (funcall function text (1- position) end))) - (if (or (error-result-p result) (not (equal (result-position result) position))) - (make-failed-parse - :position position - :expression expression - :detail result) - (make-result - :position position))))))) - - -;;; Semantic predicates - -(defun eval-semantic-predicate (expression text position end) - (with-expression (expression (t subexpr)) - (let ((result (eval-expression subexpr text position end))) - (if (error-result-p result) - (make-failed-parse - :position position - :expression expression - :detail result) - (let ((production (result-production result))) - (if (funcall (symbol-function (car expression)) production) - result - (make-failed-parse - :position position - :expression expression))))))) - -(defun compile-semantic-predicate (expression) - (with-expression (expression (t subexpr)) - (let* ((function (compile-expression subexpr)) - (predicate (car expression)) - ;; KLUDGE: Calling via a variable symbol can be slow, and if we - ;; grab the SYMBOL-FUNCTION here we will not see redefinitions. - (semantic-function - (if (eq (symbol-package predicate) (load-time-value (find-package :cl))) - (symbol-function predicate) - (compile nil `(lambda (x) (,predicate x)))))) - (named-lambda compiled-semantic-predicate (text position end) - (let ((result (funcall function text position end))) - (if (error-result-p result) - (make-failed-parse - :position position - :expression expression - :detail result) - (let ((production (result-production result))) - (if (funcall semantic-function production) - result - (make-failed-parse - :position position - :expression expression))))))))) - -;;; Character ranges - -(defun exec-character-ranges (expression ranges text position end) - (flet ((oops () - (make-failed-parse - :expression expression - :position position))) - (if (< position end) - (let ((char (char text position))) - (if (loop for range in ranges - do (if (characterp range) - (when (char= range char) - (return t)) - (when (char<= (first range) char (second range)) - (return t)))) - (make-result - :production char - :position (1+ position)) - (oops))) - (oops)))) - -(defun eval-character-ranges (expression text position end) - (with-expression (expression (character-ranges &rest ranges)) - (exec-character-ranges expression ranges text position end))) - -(defun compile-character-ranges (expression) - (with-expression (expression (character-ranges &rest ranges)) - (named-lambda compiled-character-ranges (text position end) - (exec-character-ranges expression ranges text position end)))) - -(defun eval-cond (expression text position end) - (funcall (compile-cond expression) - text position end)) - -(defun compile-cond (expression) - (with-expression (expression (cond &rest subexprs)) - (let ((functions (iter (for subexp in subexprs) - (collect `(,(if (and (symbolp (car subexp)) - (or (eql (car subexp) 't) - (eql (car subexp) 'otherwise))) - (lambda (text start end) - (declare (ignore text end)) - (make-result :position start - :production (lambda () t))) - (compile-expression (car subexp))) - ,(compile-expression (cadr subexp))))))) - (named-lambda compiled-cond (text position end) - (let (pred-result result last-error) - (macrolet ((mark-result-as-last-error (&optional (result-var 'result)) - `(when (or (and (not last-error) - (or (inactive-rule-p ,result-var) - (< position (failed-parse-position ,result-var)))) - (and last-error - (failed-parse-p ,result-var) - (or (inactive-rule-p last-error) - (< (failed-parse-position last-error) - (failed-parse-position ,result-var))))) - (setf last-error ,result-var)))) - (iter (for (predicate value-function) in functions) - (setf pred-result (funcall predicate text position end)) - (if (error-result-p pred-result) - (mark-result-as-last-error pred-result) - (progn (setf result (funcall value-function text - (result-position pred-result) end)) - (if (error-result-p result) - (mark-result-as-last-error) - (terminate)))) - (finally (return (if (and result (not (error-result-p result))) - result - (make-failed-parse - :expression expression - :position (if (and last-error - (failed-parse-p last-error)) - (failed-parse-position last-error) - position) - :detail last-error))))))))))) - -(defun eval-first (expression text position end) - (funcall (compile-first expression) - text position end)) - -(defun compile-first (expression) - (with-expression (expression (first subexpr)) - (let ((function (compile-expression subexpr))) - (named-lambda compiled-first (text position end) - (let ((result (funcall function text position end))) - (if (error-result-p result) - result - (make-result - :position (result-position result) - :production (car (result-production result))))))))) - - -(defvar *indentation-hint-table* nil) - -(defun hint-slime-indentation () - (let* ((swank (find-package :swank)) - (tables (when swank - (find-symbol (string '#:*application-hints-tables*) swank)))) - (when tables - (let ((table (make-hash-table :test #'eq))) - (setf (gethash 'defrule table) - '(4 4 &rest (&whole 2 &lambda &body))) - (set tables (cons table (remove *indentation-hint-table* (symbol-value tables)))) - (setf *indentation-hint-table* table)) - t))) - -(hint-slime-indentation) diff --git a/memoization.lisp b/memoization.lisp deleted file mode 100644 index b155d03..0000000 --- a/memoization.lisp +++ /dev/null @@ -1,53 +0,0 @@ -;;;; memoization.lisp - -;;; MEMOIZATION CACHE -;;; -;;; Because each [rule, position] tuple has an unambiguous -;;; result per source text, we can cache this result -- this is what -;;; makes packrat parsing O(N). -;;; -;;; For now we just use EQUAL hash-tables, but a specialized -;;; representation would probably pay off. - -(in-package :esrap) - -(defparameter contexts nil) -(defmacro register-context (context-sym) - `(push ',context-sym contexts)) - -(defvar *cache*) - -(defun make-cache () - (make-hash-table :test #'equal)) - -(defun get-cached (symbol position cache) - (gethash `(,symbol ,position ,@(mapcar #'symbol-value contexts)) cache)) - -(defun (setf get-cached) (result symbol position cache) - (setf (gethash `(,symbol ,position ,@(mapcar #'symbol-value contexts)) cache) result)) - -(defvar *nonterminal-stack* nil) - -(defun hash->assoc (hash) - (iter (for (key val) in-hashtable hash) - (collect `(,key . ,val)))) - -;;; SYMBOL, POSITION, and CACHE must all be lexical variables! -(defmacro with-cached-result ((symbol position &optional (text nil)) &body forms) - (with-gensyms (cache result) - `(let* ((,cache *cache*) - (,result (get-cached ,symbol ,position ,cache)) - (*nonterminal-stack* (cons ,symbol *nonterminal-stack*))) - (cond ((eq t ,result) - (error 'left-recursion - :text ,text - :position ,position - :nonterminal ,symbol - :path (reverse *nonterminal-stack*))) - (,result - ,result) - (t - ;; First mark this pair with T to detect left-recursion, - ;; then compute the result and cache that. - (setf (get-cached ,symbol ,position ,cache) t - (get-cached ,symbol ,position ,cache) (locally ,@forms))))))) diff --git a/package.lisp b/package.lisp deleted file mode 100644 index 26afb85..0000000 --- a/package.lisp +++ /dev/null @@ -1,37 +0,0 @@ -(in-package #:cl-user) - -(defpackage :esrap - (:use :cl :alexandria :defmacro-enhance :iterate) - (:shadowing-import-from :rutils.string :strcat) - #+sbcl - (:lock t) - (:export - #:&bounds - - #:! #:? #:+ #:* #:& #:~ #:<- #:-> - #:character-ranges #:wrap #:tag - - #:add-rule - #:register-context - #:call-transform - #:change-rule - #:concat - #:defrule - #:describe-grammar - #:esrap-error - #:esrap-error-position - #:esrap-error-text - #:find-rule - #:left-recursion - #:left-recursion-nonterminal - #:left-recursion-path - #:parse - #:remove-rule - #:rule - #:rule-dependencies - #:rule-expression - #:rule-symbol - #:text - #:trace-rule - #:untrace-rule - )) diff --git a/rule-storage.lisp b/rule-storage.lisp deleted file mode 100644 index ab217dd..0000000 --- a/rule-storage.lisp +++ /dev/null @@ -1,140 +0,0 @@ -;;;; rule-storage.lisp - -(in-package :esrap) - - -;;; RULE REPRESENTATION AND STORAGE -;;; -;;; For each rule, there is a RULE-CELL in *RULES*, whose %INFO slot has the -;;; function that implements the rule in car, and the rule object in CDR. A -;;; RULE object can be attached to only one non-terminal at a time, which is -;;; accessible via RULE-SYMBOL. - -(defvar *rules* (make-hash-table)) - -(defun clear-rules () - (clrhash *rules*) - nil) - -(defstruct (rule-cell (:constructor - make-rule-cell - (symbol &aux (%info (cons (undefined-rule-function symbol) nil)))) - (:conc-name cell-)) - (%info (required-argument) :type (cons function t)) - (trace-info nil) - (referents nil :type list)) - -(declaim (inline cell-function)) -(defun cell-function (cell) - (car (cell-%info cell))) - -(defun cell-rule (cell) - (cdr (cell-%info cell))) - -(defun set-cell-info (cell function rule) - ;; Atomic update - (setf (cell-%info cell) (cons function rule)) - (let ()) - cell) - -(defun undefined-rule-function (symbol) - (lambda (&rest args) - (declare (ignore args)) - (error "Undefined rule: ~S" symbol))) - -(defun ensure-rule-cell (symbol) - (check-type symbol nonterminal) - ;; FIXME: Need to lock *RULES*. - (or (gethash symbol *rules*) - (setf (gethash symbol *rules*) - (make-rule-cell symbol)))) - -(defun delete-rule-cell (symbol) - (remhash symbol *rules*)) - -(defun reference-rule-cell (symbol referent) - (let ((cell (ensure-rule-cell symbol))) - (when referent - (pushnew referent (cell-referents cell))) - cell)) - -(defun dereference-rule-cell (symbol referent) - (let ((cell (ensure-rule-cell symbol))) - (setf (cell-referents cell) (delete referent (cell-referents cell))) - cell)) - -(defun find-rule-cell (symbol) - (check-type symbol nonterminal) - (gethash symbol *rules*)) - -(defclass rule () - ((%symbol - :initform nil) - (%expression - :initarg :expression - :initform (required-argument :expression)) - (%guard-expression - :initarg :guard-expression - :initform t - :reader rule-guard-expression) - ;; Either T for rules that are always active (the common case), - ;; NIL for rules that are never active, or a function to call - ;; to find out if the rule is active or not. - (%condition - :initarg :condition - :initform t - :reader rule-condition) - (%transform - :initarg :transform - :initform nil - :reader rule-transform) - (%around - :initarg :around - :initform nil - :reader rule-around))) - -(defun rule-symbol (rule) - "Returns the nonterminal associated with the RULE, or NIL of the rule -is not attached to any nonterminal." - (slot-value rule '%symbol)) - -(defun detach-rule (rule) - (dolist (dep (%rule-direct-dependencies rule)) - (dereference-rule-cell dep (rule-symbol rule))) - (setf (slot-value rule '%symbol) nil)) - -(defmethod shared-initialize :after ((rule rule) slots &key) - (validate-expression (rule-expression rule))) - -(defmethod print-object ((rule rule) stream) - (print-unreadable-object (rule stream :type t :identity nil) - (let ((symbol (rule-symbol rule))) - (if symbol - (format stream "~S <- " symbol) - (format stream "(detached) "))) - (write (rule-expression rule) :stream stream))) - -(defun sort-dependencies (symbol dependencies) - (let ((symbols (delete symbol dependencies)) - (defined nil) - (undefined nil)) - (dolist (sym symbols) - (if (find-rule sym) - (push sym defined) - (push sym undefined))) - (values defined undefined))) - -(defun rule-dependencies (rule) - "Returns the dependencies of the RULE: primary value is a list of defined -nonterminal symbols, and secondary value is a list of undefined nonterminal -symbols." - (sort-dependencies - (rule-symbol rule) (%expression-dependencies (rule-expression rule) nil))) - -(defun rule-direct-dependencies (rule) - (sort-dependencies - (rule-symbol rule) (%expression-direct-dependencies (rule-expression rule) nil))) - -(defun %rule-direct-dependencies (rule) - (delete (rule-symbol rule) (%expression-direct-dependencies (rule-expression rule) nil))) - diff --git a/src/basic-rules.lisp b/src/basic-rules.lisp new file mode 100644 index 0000000..1b8432f --- /dev/null +++ b/src/basic-rules.lisp @@ -0,0 +1,38 @@ +;;;; basic-rules.lisp + +;;;; This is a part of esrap-liquid TDPL for Common Lisp +;;;; Alexander Popolitov, 2013 +;;;; For licence, see COPYING + +(in-package #:esrap) + +(enable-read-macro-tokens) + +(defrule any-string (length) + (let ((limit (+ length position))) + (if (<= limit end) + (make-result (subseq text position limit) length) + (fail-parse (literal-string "Unable to parse any string of specified length."))))) +(defmacro any-string (length) + `(descend-with-rule 'any-string ,length)) + + +(defrule character (char) + (if (< position end) + (if char + (let ((it (char text position))) + (if (char= it char) + (make-result it 1) + (fail-parse (literal-string "Char ~a is not equal to desired char ~a") it char))) + (make-result (char text position) 1)) + (fail-parse (literal-string "EOF reached while trying to parse character.")))) + +(defrule string (string) + (let ((any-string (any-string (length string)))) + (if (string= any-string string) + (make-result any-string)))) + +(defun joinl (joinee lst) + (format nil (strcat "~{~a~^" joinee "~}") lst)) + + diff --git a/conditions.lisp b/src/conditions.lisp similarity index 97% rename from conditions.lisp rename to src/conditions.lisp index f82d682..c0e45df 100644 --- a/conditions.lisp +++ b/src/conditions.lisp @@ -1,5 +1,10 @@ ;;;; conditions.lisp +;;;; This is a part of esrap-liquid TDPL for Common Lisp +;;;; Alexander Popolitov, 2013 +;;;; For licence, see COPYING + + (in-package :esrap) (define-condition esrap-error (parse-error) @@ -73,7 +78,6 @@ the error occurred.")) `(let ((reason (apply #'format `(nil ,,reason ,,@args)))) (simple-esrap-error text position reason "~a~%" reason))) - (define-condition left-recursion (esrap-error) ((nonterminal :initarg :nonterminal :initform nil :reader left-recursion-nonterminal) (path :initarg :path :initform nil :reader left-recursion-path)) diff --git a/src/esrap.lisp b/src/esrap.lisp new file mode 100644 index 0000000..36a90fa --- /dev/null +++ b/src/esrap.lisp @@ -0,0 +1,56 @@ +;;;; esrap.lisp + +;;;; This is a part of esrap-liquid TDPL for Common Lisp +;;;; Alexander Popolitov, 2013 +;;;; For licence, see COPYING + +(in-package :esrap) + +;;; MAIN INTERFACE + +(defun parse (expression text &key (start 0) end junk-allowed) + "Parses TEXT using EXPRESSION from START to END. Incomplete parses +are allowed only if JUNK-ALLOWED is true." + ;; There is no backtracking in the toplevel expression -- so there's + ;; no point in compiling it as it will be executed only once -- unless + ;; it's a constant, for which we have a compiler-macro. + (let ((end (or end (length text))) + (position start) + (*cache* (make-cache))) + (let ((result (descend-with-rule expression))) + (if (and (not junk-allowed) + (not (equal end position))) + (fail-parse "Didnt make it to the end of the text") + (values result position))))) + +(defun esrap-char-reader (char-reader) + (lambda (stream char subchar) + `(descend-with-rule 'character ,(funcall char-reader stream char subchar)))) +(defun esrap-string-reader (string-reader) + (lambda (stream char) + `(descend-with-rule 'string ,(funcall string-reader stream char)))) +(defun esrap-literal-char-reader (char-reader) + (lambda (stream token) + (with-dispatch-macro-character (#\# #\\ char-reader) + (car (read-list-old stream token))))) +(defun esrap-literal-string-reader (string-reader) + (lambda (stream token) + (with-macro-character (#\" string-reader) + (car (read-list-old stream token))))) + + +(defvar *indentation-hint-table* nil) + +(defun hint-slime-indentation () + (let* ((swank (find-package :swank)) + (tables (when swank + (find-symbol (string '#:*application-hints-tables*) swank)))) + (when tables + (let ((table (make-hash-table :test #'eq))) + (setf (gethash 'defrule table) + '(4 4 &rest (&whole 2 &lambda &body))) + (set tables (cons table (remove *indentation-hint-table* (symbol-value tables)))) + (setf *indentation-hint-table* table)) + t))) + +(hint-slime-indentation) diff --git a/src/macro.lisp b/src/macro.lisp new file mode 100644 index 0000000..4c1f275 --- /dev/null +++ b/src/macro.lisp @@ -0,0 +1,153 @@ +;;;; macro.lisp + +;;;; This is a part of esrap-liquid TDPL for Common Lisp +;;;; Alexander Popolitov, 2013 +;;;; For licence, see COPYING + +(in-package #:esrap) + +(defmacro! descend-with-rule (o!-sym &rest args) + `(multiple-value-bind (,g!-it ,g!-got) (gethash ,o!-sym *rules*) + (format t "sym: ~a ~a~%" ,o!-sym position) + (if (not ,g!-got) + (error "Undefined rule: ~s" ,o!-sym) + (multiple-value-bind (result new-position) (funcall ,g!-it text position end ,@args) + (format t "position before setting ~a, after setting would be ~a" position new-position) + (setf position new-position) + result)))) + +(defmacro!! defrule (name args &body body) + (let ((char-reader (get-dispatch-macro-character #\# #\\)) + (string-reader (get-macro-character #\"))) + (with-dispatch-macro-character (#\# #\\ (esrap-char-reader char-reader)) + (with-macro-character (#\" (esrap-string-reader string-reader)) + (read-macrolet ((literal-char (esrap-literal-char-reader char-reader)) + (literal-string (esrap-literal-string-reader string-reader))) + (call-next-method))))) + (let ((*variable-transformer* (lambda (sym) + ;; KLUDGE to not parse lambda-lists in defrule args + (if (equal "CHARACTER" (string sym)) + `(descend-with-rule 'character nil) + `(descend-with-rule ',sym))))) + `(setf (gethash ',name *rules*) + ,(macroexpand-all-transforming-undefs `(named-lambda ,(intern (strcat "ESRAP-" name)) (text position end ,@args) + (let ((,g!-position position)) + (declare (ignorable ,g!-position)) + (symbol-macrolet ((match-start ,g!-position) + (match-end position)) + (with-cached-result (,name position text ,@args) + (values (progn ,@body) + position))))))))) + +(defmacro! make-result (result &optional (length 0)) + ;; We must preserve the semantics, that computation of results occurs before increment of position + `(let ((,g!-result ,result)) + (incf position ,length) + (values ,g!-result position))) + + +(defmacro! || (&rest clauses) + `(multiple-value-bind (,g!-result ,g!-position) + ;; All this tricky business with BLOCK just for automatic POSITION tracking. + (block ,g!-ordered-choice + (let (,g!-parse-errors) + ,@(mapcar (lambda (clause) + `(handler-case (let ((position position)) + (return-from ,g!-ordered-choice (values ,clause position))) + (simple-esrap-error (e) (push e ,g!-parse-errors)))) + clauses) + (fail-parse (joinl "~%" + (mapcar (lambda (x) + (slot-value x 'reason)) + (nreverse ,g!-parse-errors)))))) + (setf position ,g!-position) + ,g!-result)) + + +(defmacro ! (expr) + "Succeeds, whenever parsing of EXPR fails. Does not consume." + `(progn (let ((position position)) + (handler-case ,expr + (simple-esrap-error (e) nil) + (:no-error () (fail-parse "Clause under non-consuming negation succeeded.")))) + (make-result t 0))) + +(defmacro !! (expr) + "Succeeds, whenever parsing of EXPR fails. Consumes, assumes than EXPR parses just one character." + `(progn (let ((position position)) + (handler-case ,expr + (simple-esrap-error (e) nil) + (:no-error () (fail-parse "Clause under non-consuming negation succeeded.")))) + (make-result (char text position) 1))) + +(defmacro! times (subexpr &key from upto exactly) + (flet ((frob (condition) + `(let (,g!-result) + (iter (let ((,g!-position (handler-case (let ((position position)) + (push ,subexpr ,g!-result) + position) + (simple-esrap-error () (terminate))))) + (setf position ,g!-position)) + (finally (if ,condition + (return (make-result (nreverse ,g!-result))) + (fail-parse "Greedy repetition failed."))))))) + (cond (exactly (if (or from upto) + (error "keywords :EXACTLY and :FROM/:UPTO are mutually exclusive.") + (frob `(equal (length ,g!-result) ,exactly)))) + (from (if upto + (frob `(and (>= (length ,g!-result) ,from) + (<= (length ,g!-result) ,upto))) + (frob `(>= (length ,g!-result) ,from)))) + (upto (frob `(<= (length ,g!-result) ,upto))) + (t (frob t))))) + +(defmacro postimes (subexpr) + `(times ,subexpr :from 1)) + +(defmacro! pred (predicate subexpr) + `(let ((,g!-it ,subexpr)) + (if (funcall ,predicate ,g!-it) + ,g!-it + (fail-parse "Predicate test failed")))) + +(defmacro progm (start meat end) + "Prog Middle." + `(progn ,start (prog1 ,meat ,end))) + +(defmacro! ? (subexpr) + `(multiple-value-bind (,g!-result ,g!-position) + (block ,g!-? + (let ((position position)) + (handler-case ,subexpr + (simple-esrap-error () nil) + (:no-error (result) (return-from ,g!-? (make-result result)))) + (make-result nil))) + (when ,g!-position + (setf position ,g!-position)) + ,g!-result)) + +(defmacro & (subexpr) + `(make-result (let ((position position)) + ,subexpr))) + +(defmacro -> (subexpr) + `(progn (let ((position position)) + ,subexpr) + (make-result nil))) + +(defmacro! <- (subexpr) + (if (and (symbolp subexpr) (equal (string subexpr) "SOF")) + `(if (equal 0 position) + (make-result t) + (fail-parse "not at start-of-file")) + `(let ((,g!-old-position position) + (position (1- position))) + (let ((,g!-result ,subexpr)) + (if (equal ,g!-old-position position) + (make-result ,g!-result) + (fail-parse "Parsing of subexpr took more than 1 char.")))))) + +(defmacro! cond-parse (&rest clauses) + `(|| ,@(mapcar (lambda (clause) + `(progn ,@clause)) + clauses))) diff --git a/src/macro.lisp~ b/src/macro.lisp~ new file mode 100644 index 0000000..d76a2a4 --- /dev/null +++ b/src/macro.lisp~ @@ -0,0 +1,144 @@ +(in-package #:esrap) + +(defmacro! descend-with-rule (o!-sym &rest args) + `(multiple-value-bind (,g!-it ,g!-got) (gethash ,o!-sym *rules*) + (format t "sym: ~a ~a~%" ,o!-sym position) + (if (not ,g!-got) + (error "Undefined rule: ~s" ,o!-sym) + (multiple-value-bind (result new-position) (funcall ,g!-it text position end ,@args) + (format t "position before setting ~a, after setting would be ~a" position new-position) + (setf position new-position) + result)))) + +(defmacro!! defrule (name args &body body) + (let ((char-reader (get-dispatch-macro-character #\# #\\)) + (string-reader (get-macro-character #\"))) + (with-dispatch-macro-character (#\# #\\ (esrap-char-reader char-reader)) + (with-macro-character (#\" (esrap-string-reader string-reader)) + (read-macrolet ((literal-char (esrap-literal-char-reader char-reader)) + (literal-string (esrap-literal-string-reader string-reader))) + (call-next-method))))) + (let ((*variable-transformer* (lambda (sym) + ;; KLUDGE to not parse lambda-lists in defrule args + (if (equal "CHARACTER" (string sym)) + `(descend-with-rule 'character nil) + `(descend-with-rule ',sym))))) + `(setf (gethash ',name *rules*) + ,(macroexpand-all-transforming-undefs `(named-lambda ,(intern (strcat "ESRAP-" name)) (text position end ,@args) + (let ((,g!-position position)) + (declare (ignorable ,g!-position)) + (symbol-macrolet ((match-start ,g!-position) + (match-end position)) + (with-cached-result (,name position text ,@args) + (values (progn ,@body) + position))))))))) + +(defmacro! make-result (result &optional (length 0)) + ;; We must preserve the semantics, that computation of results occurs before increment of position + `(let ((,g!-result ,result)) + (incf position ,length) + (values ,g!-result position))) + + +(defmacro! || (&rest clauses) + `(multiple-value-bind (,g!-result ,g!-position) + ;; All this tricky business with BLOCK just for automatic POSITION tracking. + (block ,g!-ordered-choice + (let (,g!-parse-errors) + ,@(mapcar (lambda (clause) + `(handler-case (let ((position position)) + (return-from ,g!-ordered-choice (values ,clause position))) + (simple-esrap-error (e) (push e ,g!-parse-errors)))) + clauses) + (fail-parse (joinl "~%" + (mapcar (lambda (x) + (slot-value x 'reason)) + (nreverse ,g!-parse-errors)))))) + (setf position ,g!-position) + ,g!-result)) + + +(defmacro ! (expr) + "Succeeds, whenever parsing of EXPR fails. Does not consume." + `(progn (let ((position position)) + (handler-case ,expr + (simple-esrap-error (e) nil) + (:no-error () (fail-parse "Clause under non-consuming negation succeeded.")))) + (make-result t 0))) + +(defmacro !! (expr) + "Succeeds, whenever parsing of EXPR fails. Consumes, assumes than EXPR parses just one character." + `(progn (let ((position position)) + (handler-case ,expr + (simple-esrap-error (e) nil) + (:no-error () (fail-parse "Clause under non-consuming negation succeeded.")))) + (make-result (char text position) 1))) + +(defmacro! times (subexpr &key from upto exactly) + (flet ((frob (condition) + `(let (,g!-result) + (iter (handler-case (push ,subexpr ,g!-result) + (simple-esrap-error () (terminate))) + (finally (if ,condition + (return (make-result (nreverse ,g!-result))) + (fail-parse "Greedy repetition failed."))))))) + (cond (exactly (if (or from upto) + (error "keywords :EXACTLY and :FROM/:UPTO are mutually exclusive.") + (frob `(equal (length ,g!-result) ,exactly)))) + (from (if upto + (frob `(and (>= (length ,g!-result) ,from) + (<= (length ,g!-result) ,upto))) + (frob `(>= (length ,g!-result) ,from)))) + (upto (frob `(<= (length ,g!-result) ,upto))) + (t (frob t))))) + +(defmacro postimes (subexpr) + `(times ,subexpr :from 1)) + +(defmacro! pred (predicate subexpr) + `(let ((,g!-it ,subexpr)) + (if (funcall ,predicate ,g!-it) + ,g!-it + (fail-parse "Predicate test failed")))) + +(defmacro progm (start meat end) + "Prog Middle." + `(progn ,start (prog1 ,meat ,end))) + +(defmacro! ? (subexpr) + `(multiple-value-bind (,g!-result ,g!-position) + (block ,g!-? + (let ((position position)) + (handler-case ,subexpr + (simple-esrap-error () nil) + (:no-error (result) (return-from ,g!-? (make-result result)))) + (make-result nil))) + (when ,g!-position + (setf position ,g!-position)) + ,g!-result)) + +(defmacro & (subexpr) + `(make-result (let ((position position)) + ,subexpr))) + +(defmacro -> (subexpr) + `(progn (let ((position position)) + ,subexpr) + (make-result nil))) + +(defmacro! <- (subexpr) + (if (and (symbolp subexpr) (equal (string subexpr) "SOF")) + `(if (equal 0 position) + (make-result t) + (fail-parse "not at start-of-file")) + `(let ((,g!-old-position position) + (position (1- position))) + (let ((,g!-result ,subexpr)) + (if (equal ,g!-old-position position) + (make-result ,g!-result) + (fail-parse "Parsing of subexpr took more than 1 char.")))))) + +(defmacro! cond-parse (&rest clauses) + `(|| ,@(mapcar (lambda (clause) + `(progn ,@clause)) + clauses))) diff --git a/src/memoization.lisp b/src/memoization.lisp new file mode 100644 index 0000000..6fac5d2 --- /dev/null +++ b/src/memoization.lisp @@ -0,0 +1,60 @@ +;;;; memoization.lisp + +;;;; This is a part of esrap-liquid TDPL for Common Lisp +;;;; Alexander Popolitov, 2013 +;;;; For licence, see COPYING + +(in-package :esrap) + +(defparameter contexts nil) +(defmacro register-context (context-sym) + `(push ',context-sym contexts)) + +(defvar *cache*) + +(defun make-cache () + (make-hash-table :test #'equal)) + +(defun get-cached (symbol position args cache) + (gethash `(,symbol ,position ,args ,@(mapcar #'symbol-value contexts)) cache)) + +(defun (setf get-cached) (result symbol position cache) + (setf (gethash `(,symbol ,position ,@(mapcar #'symbol-value contexts)) cache) result)) + +(defvar *nonterminal-stack* nil) + +(defun hash->assoc (hash) + (iter (for (key val) in-hashtable hash) + (collect `(,key . ,val)))) + +(defun failed-parse-p (e) + (typep e 'simple-esrap-error)) + +;;; SYMBOL, POSITION, and CACHE must all be lexical variables! +(defmacro! with-cached-result ((symbol position text &rest args) &body forms) + `(let* ((,g!-cache *cache*) + (,g!-result (get-cached ',symbol ,position (list ,@args) ,g!-cache)) + (*nonterminal-stack* (cons ',symbol *nonterminal-stack*))) + (cond ((eq :left-recursion ,g!-result) + (error 'left-recursion + :text ,text + :position ,position + :nonterminal ',symbol + :path (reverse *nonterminal-stack*))) + (,g!-result (if (failed-parse-p ,g!-result) + (error ,g!-result) + (values (car ,g!-result) (cdr ,g!-result)))) + (t + ;; First mark this pair with :LEFT-RECURSION to detect left-recursion, + ;; then compute the result and cache that. + (setf (get-cached ',symbol ,position ,g!-cache) :left-recursion) + (multiple-value-bind (result position) (handler-case (locally ,@forms) + (simple-esrap-error (e) e)) + ;; POSITION is non-NIL only for successful parses + (if position + (progn (setf (get-cached ',symbol ,position ,g!-cache) + (cons result position)) + (values result position)) + (progn (setf (get-cached ',symbol ,position ,g!-cache) + result) + (error result)))))))) diff --git a/miscellany.lisp b/src/miscellany.lisp similarity index 95% rename from miscellany.lisp rename to src/miscellany.lisp index e01e4ed..a5a5bdf 100644 --- a/miscellany.lisp +++ b/src/miscellany.lisp @@ -1,4 +1,8 @@ -;;; miscellany.lisp +;;;; miscellany.lisp + +;;;; This is a part of esrap-liquid TDPL for Common Lisp +;;;; Alexander Popolitov, 2013 +;;;; For licence, see COPYING (in-package :esrap) diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..4a6b3d6 --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,21 @@ +;;;; package.lisp + +;;;; This is a part of esrap-liquid TDPL for Common Lisp +;;;; Alexander Popolitov, 2013 +;;;; For licence, see COPYING + +(in-package #:cl-user) + +(defpackage :esrap + (:use #:cl #:alexandria #:defmacro-enhance #:iterate #:cl-indeterminism #:cl-read-macro-tokens) + (:shadowing-import-from #:rutils.string #:strcat) + (:export + #:enable-read-macro-tokens #:disable-read-macro-tokens + #:! #:? #:& #:~ #:<- #:-> #:!! #:times #:postimes #:pred #:progm #:cond-parse + #:literal-string #:literal-char + #:register-context + #:concat + #:defrule #:descend-with-rule #:any-string #:character #:string #:|| + #:parse + #:text + )) diff --git a/src/rule-storage.lisp b/src/rule-storage.lisp new file mode 100644 index 0000000..8cdff28 --- /dev/null +++ b/src/rule-storage.lisp @@ -0,0 +1,23 @@ +;;;; rule-storage.lisp + +;;;; This is a part of esrap-liquid TDPL for Common Lisp +;;;; Alexander Popolitov, 2013 +;;;; For licence, see COPYING + +(in-package :esrap) + + +;;; RULE REPRESENTATION AND STORAGE +;;; +;;; For each rule, there is a RULE-CELL in *RULES*, whose %INFO slot has the +;;; function that implements the rule in car, and the rule object in CDR. A +;;; RULE object can be attached to only one non-terminal at a time, which is +;;; accessible via RULE-SYMBOL. + +(defvar *rules* (make-hash-table)) + +(defun clear-rules () + (clrhash *rules*) + nil) + + diff --git a/tests.lisp b/tests.lisp deleted file mode 100644 index ddc030d..0000000 --- a/tests.lisp +++ /dev/null @@ -1,371 +0,0 @@ -;;;; Copyright (c) 2007-2013 Nikodemus Siivola -;;;; -;;;; Permission is hereby granted, free of charge, to any person -;;;; obtaining a copy of this software and associated documentation files -;;;; (the "Software"), to deal in the Software without restriction, -;;;; including without limitation the rights to use, copy, modify, merge, -;;;; publish, distribute, sublicense, and/or sell copies of the Software, -;;;; and to permit persons to whom the Software is furnished to do so, -;;;; subject to the following conditions: -;;;; -;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -(in-package :cl-user) - -(defpackage :esrap-tests - (:use :alexandria :cl :esrap :eos) - (:shadowing-import-from :esrap "!") - (:export #:run-tests)) - -(in-package :esrap-tests) - -(def-suite esrap) -(in-suite esrap) - -;;;; A few semantic predicates - -(defun not-doublequote (char) - (not (eql #\" char))) - -(defun not-digit (char) - (when (find-if-not #'digit-char-p char) - t)) - -(defun not-newline (char) - (not (eql #\newline char))) - -(defun not-space (char) - (not (eql #\space char))) - -;;;; Utility rules - -(defrule whitespace (+ (or #\space #\tab #\newline)) - (:text t)) - -(defrule empty-line #\newline - (:constant "")) - -(defrule non-empty-line (and (+ (not-newline character)) (? #\newline)) - (:destructure (text newline) - (declare (ignore newline)) - (text text))) - -(defrule line (or empty-line non-empty-line) - (:identity t)) - -(defrule trimmed-line line - (:lambda (line) - (string-trim '(#\space #\tab) line))) - -(defrule trimmed-lines (* trimmed-line) - (:identity t)) - -(defrule digits (+ (digit-char-p character)) - (:text t)) - -(defrule integer (and (? whitespace) - digits - (and (? whitespace) (or (& #\,) (! character)))) - (:destructure (whitespace digits tail) - (declare (ignore whitespace tail)) - (parse-integer digits))) - -(defrule list-of-integers (+ (or (and integer #\, list-of-integers) - integer)) - (:destructure (match) - (if (integerp match) - (list match) - (destructuring-bind (int comma list) match - (declare (ignore comma)) - (cons int list))))) - -(test smoke - (is (equal '("1," "2," "" "3," "4.") - (parse 'trimmed-lines "1, - 2, - - 3, - 4."))) - (is (eql 123 (parse 'integer " 123"))) - (is (eql 123 (parse 'integer " 123 "))) - (is (eql 123 (parse 'integer "123 "))) - (is (equal '(123 45 6789 0) (parse 'list-of-integers "123, 45 , 6789, 0"))) - (is (equal '(123 45 6789 0) (parse 'list-of-integers " 123 ,45,6789, 0 ")))) - -(defrule single-token/bounds.1 (+ (not-space character)) - (:lambda (result &bounds start end) - (format nil "~A[~S-~S]" (text result) start end))) - -(defrule single-token/bounds.2 (and (not-space character) (* (not-space character))) - (:destructure (first &rest rest &bounds start end) - (format nil "~C~A(~S-~S)" first (text rest) start end))) - -(defrule tokens/bounds.1 (and (? whitespace) - (or (and single-token/bounds.1 whitespace tokens/bounds.1) - single-token/bounds.1)) - (:destructure (whitespace match) - (declare (ignore whitespace)) - (if (stringp match) - (list match) - (destructuring-bind (token whitespace list) match - (declare (ignore whitespace)) - (cons token list))))) - -(defrule tokens/bounds.2 (and (? whitespace) - (or (and single-token/bounds.2 whitespace tokens/bounds.2) - single-token/bounds.2)) - (:destructure (whitespace match) - (declare (ignore whitespace)) - (if (stringp match) - (list match) - (destructuring-bind (token whitespace list) match - (declare (ignore whitespace)) - (cons token list))))) - -(defrule left-recursion (and left-recursion "l")) - -(test bounds.1 - (is (equal '("foo[0-3]") - (parse 'tokens/bounds.1 "foo"))) - (is (equal '("foo[0-3]" "bar[4-7]" "quux[11-15]") - (parse 'tokens/bounds.1 "foo bar quux")))) - -(test bounds.2 - (is (equal '("foo(0-3)") - (parse 'tokens/bounds.2 "foo"))) - (is (equal '("foo(0-3)" "bar(4-7)" "quux(11-15)") - (parse 'tokens/bounds.2 "foo bar quux")))) - -(test condition.1 - "Test signaling of `esrap-simple-parse-error' conditions for failed - parses." - (macrolet - ((signals-esrap-error ((input position &optional messages) &body body) - `(progn - (signals (esrap-error) - ,@body) - (handler-case (progn ,@body) - (esrap-error (condition) - (is (string= (esrap-error-text condition) ,input)) - (is (= (esrap-error-position condition) ,position)) - ,@(when messages - `((let ((report (princ-to-string condition))) - ,@(mapcar (lambda (message) - `(is (search ,message report))) - (ensure-list messages)))))))))) - (signals-esrap-error ("" 0 ("Could not parse subexpression" - "Encountered at")) - (parse 'integer "")) - (signals-esrap-error ("123foo" 3 ("Could not parse subexpression" - "Encountered at")) - (parse 'integer "123foo")) - (signals-esrap-error ("1, " 1 ("Incomplete parse." - "Encountered at")) - (parse 'list-of-integers "1, ")))) - -(test condition.2 - "Test signaling of `left-recursion' condition." - (signals (left-recursion) - (parse 'left-recursion "l")) - (handler-case (parse 'left-recursion "l") - (left-recursion (condition) - (is (string= (esrap-error-text condition) "l")) - (is (= (esrap-error-position condition) 0)) - (is (eq (left-recursion-nonterminal condition) - 'left-recursion)) - (is (equal (left-recursion-path condition) - '(left-recursion left-recursion)))))) - -(test negation - "Test negation in rules." - (let* ((text "FooBazBar") - (t1c (text (parse '(+ (not "Baz")) text :junk-allowed t))) - (t1e (text (parse (identity '(+ (not "Baz"))) text :junk-allowed t))) - (t2c (text (parse '(+ (not "Bar")) text :junk-allowed t))) - (t2e (text (parse (identity '(+ (not "Bar"))) text :junk-allowed t))) - (t3c (text (parse '(+ (not (or "Bar" "Baz"))) text :junk-allowed t))) - (t3e (text (parse (identity '(+ (not (or "Bar" "Baz")))) text :junk-allowed t)))) - (is (equal "Foo" t1c)) - (is (equal "Foo" t1e)) - (is (equal "FooBaz" t2c)) - (is (equal "FooBaz" t2e)) - (is (equal "Foo" t3c)) - (is (equal "Foo" t3e)))) - -(declaim (special *depth*)) -(defvar *depth* nil) - -(defrule around/inner - (+ (alpha-char-p character)) - (:text t)) - -(defrule around.1 - (or around/inner - (and #\{ around.1 #\})) - (:lambda (thing) - (if (stringp thing) - (cons *depth* thing) - (second thing))) - (:around () - (let ((*depth* (if *depth* - (cons (1+ (first *depth*)) *depth*) - (list 0)))) - (call-transform)))) - -(defrule around.2 - (or around/inner - (and #\{ around.2 #\})) - (:lambda (thing) - (if (stringp thing) - (cons *depth* thing) - (second thing))) - (:around (&bounds start end) - (let ((*depth* (if *depth* - (cons (cons (1+ (car (first *depth*))) (cons start end)) - *depth*) - (list (cons 0 (cons start end)))))) - (call-transform)))) - -(test around.1 - "Test executing code around the transform of a rule." - (macrolet ((test-case (input expected) - `(is (equal (parse 'around.1 ,input) ,expected)))) - (test-case "foo" '((0) . "foo")) - (test-case "{bar}" '((1 0) . "bar")) - (test-case "{{baz}}" '((2 1 0) . "baz")))) - -(test around.2 - "Test executing code around the transform of a rule." - (macrolet ((test-case (input expected) - `(is (equal (parse 'around.2 ,input) ,expected)))) - (test-case "foo" '(((0 . (0 . 3))) - . "foo")) - (test-case "{bar}" '(((1 . (1 . 4)) - (0 . (0 . 5))) - . "bar")) - (test-case "{{baz}}" '(((2 . (2 . 5)) - (1 . (1 . 6)) - (0 . (0 . 7))) - . "baz")))) - -(defrule character-range (character-ranges (#\a #\b) #\-)) - -(test character-range-test - (is (equal '(#\a #\b) (parse '(* (character-ranges (#\a #\z) #\-)) "ab" :junk-allowed t))) - (is (equal '(#\a #\b) (parse '(* (character-ranges (#\a #\z) #\-)) "ab1" :junk-allowed t))) - (is (equal '(#\a #\b #\-) (parse '(* (character-ranges (#\a #\z) #\-)) "ab-" :junk-allowed t))) - (is (not (parse '(* (character-ranges (#\a #\z) #\-)) "AB-" :junk-allowed t))) - (is (not (parse '(* (character-ranges (#\a #\z) #\-)) "ZY-" :junk-allowed t))) - (is (equal '(#\a #\b #\-) (parse '(* character-range) "ab-cd" :junk-allowed t)))) - -(test examples-from-readme-test - (is (equal '("foo" nil) - (multiple-value-list (parse '(or "foo" "bar") "foo")))) - (is (eq 'foo+ (add-rule 'foo+ - (make-instance 'rule :expression '(+ "foo"))))) - (is (equal '(("foo" "foo" "foo") nil) - (multiple-value-list (parse 'foo+ "foofoofoo")))) - (is (eq 'decimal - (add-rule 'decimal - (make-instance 'rule - :expression `(+ (or "0" "1" "2" "3" "4" "5" "6" "7" - "8" "9")) - :transform (lambda (list start end) - (declare (ignore start end)) - (parse-integer (format nil "~{~A~}" list))))))) - (is (eql 123 (parse '(oddp decimal) "123"))) - (is (equal '(nil 0) - (multiple-value-list (parse '(evenp decimal) "123" :junk-allowed t))))) - -;; Testing ambiguity when repetitioning possibly empty-string-match - -(defrule spaces (* #\space) - (:lambda (lst) - (length lst))) - -(defrule greedy-pos-spaces (+ spaces)) -(defrule greedy-spaces (* spaces)) - -(test ambiguous-greedy-repetitions - (is (equal '((3) nil) (multiple-value-list (parse 'greedy-spaces " ")))) - (is (equal '((3) nil) (multiple-value-list (parse 'greedy-pos-spaces " "))))) - -(defparameter separator #\space) - -(defrule simple-prefix (character-ranges (#\a #\z))) - -(defun separator-p (x) - (and (characterp x) (char= x separator))) - -(defrule separator (separator-p character)) - -(defrule word (+ (not separator)) - (:text t)) - -(defrule simple-wrapped (wrap simple-prefix - (and word - (* (and separator word)) - (? separator))) - (:wrap-around (let ((separator wrapper)) - (call-parser))) - (:destructure (word rest-words sep) - (declare (ignore sep)) - `(,word ,@(mapcar #'cadr rest-words)))) - -(test dynamic-wrapping - (is (equal '(("oo" "oo" "oo") nil) - (multiple-value-list (parse 'simple-wrapped "foofoofoof")))) - (is (equal '(("oofoofoof") nil) - (multiple-value-list (parse 'simple-wrapped "goofoofoof"))))) - -(defparameter dyna-from 3) -(defparameter dyna-to 5) - -(defrule dyna-from-to (* dyna-from dyna-to "a") - (:text t)) - -(defrule dyna-from-tos (* dyna-from-to)) - -(test dynamic-times - (is (equal '("aaaaa" "aaa") (parse 'dyna-from-tos "aaaaaaaa"))) - (is (equal '("aaaa" "aaaa") (let ((dyna-to 4)) - (parse 'dyna-from-tos "aaaaaaaa"))))) - -(defrule cond-word (cond (dyna-from-to word))) - -(defparameter context :void) - -(defun in-context-p (x) - (declare (ignore x)) - (and context (not (eql context :void)))) -(defrule context (in-context-p "")) -(defrule ooc-word word - (:constant "out of context word")) -(test cond - (is (equal "foo" (parse 'cond-word "aaaafoo"))) - (is (equal "foo" (let ((context t)) (parse '(cond (context word)) "foo")))) - (is (equal :error-occured (handler-case (parse '(cond (context word)) "foo") - (error () :error-occured)))) - (is (equal "out of context word" (parse '(cond (context word) (t ooc-word)) - "foo")))) - -(test followed-by-not-gen - (is (equal '("a" nil "b") (parse '(and "a" (-> "b") "b") "ab")))) - -(test preceded-by-not-gen - (is (equal '("a" nil "b") (parse '(and "a" (<- "a") "b") "ab")))) - -(test on-the-fly-tagging - (is (equal '(:simple-tag "aaa") (parse '(tag :simple-tag "aaa") "aaa")))) - -(defun run-tests () - (let ((results (run 'esrap))) - (eos:explain! results) - (unless (eos:results-status results) - (error "Tests failed.")))) diff --git a/tests/package.lisp b/tests/package.lisp new file mode 100644 index 0000000..8bd34c8 --- /dev/null +++ b/tests/package.lisp @@ -0,0 +1,22 @@ +;;;; tests/package.lisp + +;;;; This is a part of esrap-liquid TDPL for Common Lisp +;;;; Alexander Popolitov, 2013 +;;;; For licence, see COPYING + + +(in-package :cl-user) + +(defpackage :esrap-tests + (:use :alexandria :cl :esrap :fiveam) + (:shadowing-import-from :esrap "!" "!!") + (:export #:run-tests)) + +(in-package :esrap-tests) + +(defun run-tests () + (let ((results (run 'esrap))) + (fiveam:explain! results) + (unless (fiveam:results-status results) + (error "Tests failed.")))) + diff --git a/tests/rules.lisp b/tests/rules.lisp new file mode 100644 index 0000000..36550c6 --- /dev/null +++ b/tests/rules.lisp @@ -0,0 +1,205 @@ +;;;; tests/rules.lisp + +;;;; This is a part of esrap-liquid TDPL for Common Lisp +;;;; Alexander Popolitov, 2013 +;;;; For licence, see COPYING + + +(in-package :esrap-tests) + +(enable-read-macro-tokens) +(cl-interpol:enable-interpol-syntax) + +;;;; A few semantic predicates + +(defun not-doublequote (char) + (not (eql #\" char))) + +(defun not-digit (char) + (when (find-if-not #'digit-char-p char) + t)) + +(defun not-newline (char) + (not (eql #\newline char))) + +(defun not-space (char) + (not (eql #\space char))) + +;;;; Utility rules + +(defrule whitespace-char () + (|| #\space #\tab #\newline)) + +(defrule whitespace () + (text (postimes whitespace-char))) + +(defrule maybe-whitespace () + (text (? whitespace))) + +(defrule maybe-whitespace-char () + (text (? whitespace-char))) + +(defrule empty-line () + (progn #\newline (literal-string ""))) + +(defrule nonewline-line () + (postimes (pred #'not-newline character))) + +(defrule a-char-line () + (postimes #\a)) + +(defrule maybe-newline () + (? #\newline)) + +(defrule non-empty-line () + (text (prog1 (postimes (pred #'not-newline character)) + (? #\newline)))) + +(defrule space () + #\space) + +(defrule line () + (|| empty-line non-empty-line)) + +(defrule trimmed-line () + (string-trim '((literal-char #\space) + (literal-char #\tab)) + line)) + +(defrule trimmed-lines () + (times trimmed-line)) + +(defrule digits () + (text (postimes (pred #'digit-char-p character)))) + +(defrule integer () + (parse-integer (progm (? whitespace) + digits + (list (? whitespace) (|| (& #\,) (! character)))))) + +(defrule list-of-integers () + (let ((it (|| (list integer #\, list-of-integers) + integer))) + (if (integerp it) + (list it) + (destructuring-bind (int comma list) it + (declare (ignore comma)) + (cons int list))))) + +(defrule single-token/bounds.1 () + (format nil "~A[~S-~S]" + (text (postimes (pred #'not-space character))) + start + end)) + +(defrule single-token/bounds.2 () + (format nil "~C~A(~S-~S)" + (pred #'not-space character) + (times (pred #'not-space character)) + start + end)) + +(defrule tokens/bounds.1 () + (let ((match (progn (? whitespace) + (|| (cons single-token/bounds.1 + (progn whitespace tokens/bounds.1)) + single-token/bounds.1)))) + (if (stringp match) + (list match) + match))) + +(defrule tokens/bounds.2 () + (let ((match (progn (? whitespace) + (|| (cons single-token/bounds.2 + (progn whitespace tokens/bounds.2)) + single-token/bounds.2)))) + (if (stringp match) + (list match) + match))) + +(defrule left-recursion () + (progn left-recursion "l")) + +;; (declaim (special *depth*)) +;; (defvar *depth* nil) + +;; (defrule around/inner +;; (+ (alpha-char-p character)) +;; (:text t)) + +;; (defrule around.1 +;; (or around/inner +;; (and #\{ around.1 #\})) +;; (:lambda (thing) +;; (if (stringp thing) +;; (cons *depth* thing) +;; (second thing))) +;; (:around () +;; (let ((*depth* (if *depth* +;; (cons (1+ (first *depth*)) *depth*) +;; (list 0)))) +;; (call-transform)))) + +;; (defrule around.2 +;; (or around/inner +;; (and #\{ around.2 #\})) +;; (:lambda (thing) +;; (if (stringp thing) +;; (cons *depth* thing) +;; (second thing))) +;; (:around (&bounds start end) +;; (let ((*depth* (if *depth* +;; (cons (cons (1+ (car (first *depth*))) (cons start end)) +;; *depth*) +;; (list (cons 0 (cons start end)))))) +;; (call-transform)))) + +;; (defrule character-range (character-ranges (#\a #\b) #\-)) + +;; ;; Testing ambiguity when repetitioning possibly empty-string-match + +;; (defrule spaces (* #\space) +;; (:lambda (lst) +;; (length lst))) + +;; (defrule greedy-pos-spaces (+ spaces)) +;; (defrule greedy-spaces (* spaces)) + +;; (defparameter separator #\space) + +;; (defrule simple-prefix (character-ranges (#\a #\z))) + +;; (defun separator-p (x) +;; (and (characterp x) (char= x separator))) + +;; (defrule separator (separator-p character)) + +;; (defrule word (+ (not separator)) +;; (:text t)) + +;; (defrule simple-wrapped (wrap simple-prefix +;; (and word +;; (* (and separator word)) +;; (? separator))) +;; (:wrap-around (let ((separator wrapper)) +;; (call-parser))) +;; (:destructure (word rest-words sep) +;; (declare (ignore sep)) +;; `(,word ,@(mapcar #'cadr rest-words)))) + +;; (defparameter dyna-from 3) +;; (defparameter dyna-to 5) + +;; (defrule dyna-from-to (* dyna-from dyna-to "a") +;; (:text t)) + +;; (defrule dyna-from-tos (* dyna-from-to)) + +;; (defparameter context :void) + +;; (defun in-context-p (x) +;; (declare (ignore x)) +;; (and context (not (eql context :void)))) +;; (defrule context (in-context-p "")) +;; (defrule ooc-word word +;; (:constant "out of context word")) diff --git a/tests/tests.lisp b/tests/tests.lisp new file mode 100644 index 0000000..a60ac1e --- /dev/null +++ b/tests/tests.lisp @@ -0,0 +1,189 @@ +;;;; tests/tests.lisp + +;;;; This is a part of esrap-liquid TDPL for Common Lisp +;;;; Alexander Popolitov, 2013 +;;;; For licence, see COPYING + +(in-package :esrap-tests) + +(enable-read-macro-tokens) +(cl-interpol:enable-interpol-syntax) + +(def-suite esrap) +(in-suite esrap) + +(test basic + (is (equal #\space (parse 'whitespace-char " "))) + (is (equal #\tab (parse 'whitespace-char #?"\t"))) + (is (equal #\newline (parse 'whitespace-char #?"\n"))) + (is (equal #?" \t\t\n\n" (parse 'whitespace #?" \t\t\n\n"))) + (is (equal "asdf" (parse 'non-empty-line #?"asdf"))) + (is (equal "asdf" (parse 'non-empty-line #?"asdf\n"))) + ) + +(test smoke + (is (equal '("1," "2," "" "3," "4.") + (parse 'trimmed-lines "1, + 2, + + 3, + 4."))) + (is (eql 123 (parse 'integer " 123"))) + (is (eql 123 (parse 'integer " 123 "))) + (is (eql 123 (parse 'integer "123 "))) + (is (equal '(123 45 6789 0) (parse 'list-of-integers "123, 45 , 6789, 0"))) + (is (equal '(123 45 6789 0) (parse 'list-of-integers " 123 ,45,6789, 0 ")))) + +;; (test bounds.1 +;; (is (equal '("foo[0-3]") +;; (parse 'tokens/bounds.1 "foo"))) +;; (is (equal '("foo[0-3]" "bar[4-7]" "quux[11-15]") +;; (parse 'tokens/bounds.1 "foo bar quux")))) + +;; (test bounds.2 +;; (is (equal '("foo(0-3)") +;; (parse 'tokens/bounds.2 "foo"))) +;; (is (equal '("foo(0-3)" "bar(4-7)" "quux(11-15)") +;; (parse 'tokens/bounds.2 "foo bar quux")))) + +;; (test condition.1 +;; "Test signaling of `esrap-simple-parse-error' conditions for failed +;; parses." +;; (macrolet +;; ((signals-esrap-error ((input position &optional messages) &body body) +;; `(progn +;; (signals (esrap-error) +;; ,@body) +;; (handler-case (progn ,@body) +;; (esrap-error (condition) +;; (is (string= (esrap-error-text condition) ,input)) +;; (is (= (esrap-error-position condition) ,position)) +;; ,@(when messages +;; `((let ((report (princ-to-string condition))) +;; ,@(mapcar (lambda (message) +;; `(is (search ,message report))) +;; (ensure-list messages)))))))))) +;; (signals-esrap-error ("" 0 ("Could not parse subexpression" +;; "Encountered at")) +;; (parse 'integer "")) +;; (signals-esrap-error ("123foo" 3 ("Could not parse subexpression" +;; "Encountered at")) +;; (parse 'integer "123foo")) +;; (signals-esrap-error ("1, " 1 ("Incomplete parse." +;; "Encountered at")) +;; (parse 'list-of-integers "1, ")))) + +;; (test condition.2 +;; "Test signaling of `left-recursion' condition." +;; (signals (left-recursion) +;; (parse 'left-recursion "l")) +;; (handler-case (parse 'left-recursion "l") +;; (left-recursion (condition) +;; (is (string= (esrap-error-text condition) "l")) +;; (is (= (esrap-error-position condition) 0)) +;; (is (eq (left-recursion-nonterminal condition) +;; 'left-recursion)) +;; (is (equal (left-recursion-path condition) +;; '(left-recursion left-recursion)))))) + +;; (test negation +;; "Test negation in rules." +;; (let* ((text "FooBazBar") +;; (t1c (text (parse '(+ (not "Baz")) text :junk-allowed t))) +;; (t1e (text (parse (identity '(+ (not "Baz"))) text :junk-allowed t))) +;; (t2c (text (parse '(+ (not "Bar")) text :junk-allowed t))) +;; (t2e (text (parse (identity '(+ (not "Bar"))) text :junk-allowed t))) +;; (t3c (text (parse '(+ (not (or "Bar" "Baz"))) text :junk-allowed t))) +;; (t3e (text (parse (identity '(+ (not (or "Bar" "Baz")))) text :junk-allowed t)))) +;; (is (equal "Foo" t1c)) +;; (is (equal "Foo" t1e)) +;; (is (equal "FooBaz" t2c)) +;; (is (equal "FooBaz" t2e)) +;; (is (equal "Foo" t3c)) +;; (is (equal "Foo" t3e)))) + +;; (test around.1 +;; "Test executing code around the transform of a rule." +;; (macrolet ((test-case (input expected) +;; `(is (equal (parse 'around.1 ,input) ,expected)))) +;; (test-case "foo" '((0) . "foo")) +;; (test-case "{bar}" '((1 0) . "bar")) +;; (test-case "{{baz}}" '((2 1 0) . "baz")))) + +;; (test around.2 +;; "Test executing code around the transform of a rule." +;; (macrolet ((test-case (input expected) +;; `(is (equal (parse 'around.2 ,input) ,expected)))) +;; (test-case "foo" '(((0 . (0 . 3))) +;; . "foo")) +;; (test-case "{bar}" '(((1 . (1 . 4)) +;; (0 . (0 . 5))) +;; . "bar")) +;; (test-case "{{baz}}" '(((2 . (2 . 5)) +;; (1 . (1 . 6)) +;; (0 . (0 . 7))) +;; . "baz")))) + +;; (test character-range-test +;; (is (equal '(#\a #\b) (parse '(* (character-ranges (#\a #\z) #\-)) "ab" :junk-allowed t))) +;; (is (equal '(#\a #\b) (parse '(* (character-ranges (#\a #\z) #\-)) "ab1" :junk-allowed t))) +;; (is (equal '(#\a #\b #\-) (parse '(* (character-ranges (#\a #\z) #\-)) "ab-" :junk-allowed t))) +;; (is (not (parse '(* (character-ranges (#\a #\z) #\-)) "AB-" :junk-allowed t))) +;; (is (not (parse '(* (character-ranges (#\a #\z) #\-)) "ZY-" :junk-allowed t))) +;; (is (equal '(#\a #\b #\-) (parse '(* character-range) "ab-cd" :junk-allowed t)))) + +;; (test examples-from-readme-test +;; (is (equal '("foo" nil) +;; (multiple-value-list (parse '(or "foo" "bar") "foo")))) +;; (is (eq 'foo+ (add-rule 'foo+ +;; (make-instance 'rule :expression '(+ "foo"))))) +;; (is (equal '(("foo" "foo" "foo") nil) +;; (multiple-value-list (parse 'foo+ "foofoofoo")))) +;; (is (eq 'decimal +;; (add-rule 'decimal +;; (make-instance 'rule +;; :expression `(+ (or "0" "1" "2" "3" "4" "5" "6" "7" +;; "8" "9")) +;; :transform (lambda (list start end) +;; (declare (ignore start end)) +;; (parse-integer (format nil "~{~A~}" list))))))) +;; (is (eql 123 (parse '(oddp decimal) "123"))) +;; (is (equal '(nil 0) +;; (multiple-value-list (parse '(evenp decimal) "123" :junk-allowed t))))) + + +;; (test ambiguous-greedy-repetitions +;; (is (equal '((3) nil) (multiple-value-list (parse 'greedy-spaces " ")))) +;; (is (equal '((3) nil) (multiple-value-list (parse 'greedy-pos-spaces " "))))) + + +;; (test dynamic-wrapping +;; (is (equal '(("oo" "oo" "oo") nil) +;; (multiple-value-list (parse 'simple-wrapped "foofoofoof")))) +;; (is (equal '(("oofoofoof") nil) +;; (multiple-value-list (parse 'simple-wrapped "goofoofoof"))))) + +;; (test dynamic-times +;; (is (equal '("aaaaa" "aaa") (parse 'dyna-from-tos "aaaaaaaa"))) +;; (is (equal '("aaaa" "aaaa") (let ((dyna-to 4)) +;; (parse 'dyna-from-tos "aaaaaaaa"))))) + +;; (defrule cond-word (cond (dyna-from-to word))) + +;; (test cond +;; (is (equal "foo" (parse 'cond-word "aaaafoo"))) +;; (is (equal "foo" (let ((context t)) (parse '(cond (context word)) "foo")))) +;; (is (equal :error-occured (handler-case (parse '(cond (context word)) "foo") +;; (error () :error-occured)))) +;; (is (equal "out of context word" (parse '(cond (context word) (t ooc-word)) +;; "foo")))) + +;; (test followed-by-not-gen +;; (is (equal '("a" nil "b") (parse '(and "a" (-> "b") "b") "ab")))) + +;; (test preceded-by-not-gen +;; (is (equal '("a" nil "b") (parse '(and "a" (<- "a") "b") "ab")))) + +;; (test on-the-fly-tagging +;; (is (equal '(:simple-tag "aaa") (parse '(tag :simple-tag "aaa") "aaa")))) + From 59e2197fa525eece8844b3902c64eef3cea1ba45 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Fri, 8 Nov 2013 04:34:50 +0400 Subject: [PATCH 18/95] Make tests involving MATCH-START and MATCH-END working --- src/package.lisp | 1 + tests/rules.lisp | 14 +++++++------- tests/tests.lisp | 22 +++++++++++----------- 3 files changed, 19 insertions(+), 18 deletions(-) diff --git a/src/package.lisp b/src/package.lisp index 4a6b3d6..0ddd6b0 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -12,6 +12,7 @@ (:export #:enable-read-macro-tokens #:disable-read-macro-tokens #:! #:? #:& #:~ #:<- #:-> #:!! #:times #:postimes #:pred #:progm #:cond-parse + #:match-start #:match-end #:literal-string #:literal-char #:register-context #:concat diff --git a/tests/rules.lisp b/tests/rules.lisp index 36550c6..c108fa3 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -87,17 +87,17 @@ (cons int list))))) (defrule single-token/bounds.1 () - (format nil "~A[~S-~S]" + (format nil (literal-string "~A[~S-~S]") (text (postimes (pred #'not-space character))) - start - end)) + match-start + match-end)) (defrule single-token/bounds.2 () - (format nil "~C~A(~S-~S)" + (format nil (literal-string "~C~A(~S-~S)") (pred #'not-space character) - (times (pred #'not-space character)) - start - end)) + (text (times (pred #'not-space character))) + match-start + match-end)) (defrule tokens/bounds.1 () (let ((match (progn (? whitespace) diff --git a/tests/tests.lisp b/tests/tests.lisp index a60ac1e..625a21e 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -34,17 +34,17 @@ (is (equal '(123 45 6789 0) (parse 'list-of-integers "123, 45 , 6789, 0"))) (is (equal '(123 45 6789 0) (parse 'list-of-integers " 123 ,45,6789, 0 ")))) -;; (test bounds.1 -;; (is (equal '("foo[0-3]") -;; (parse 'tokens/bounds.1 "foo"))) -;; (is (equal '("foo[0-3]" "bar[4-7]" "quux[11-15]") -;; (parse 'tokens/bounds.1 "foo bar quux")))) - -;; (test bounds.2 -;; (is (equal '("foo(0-3)") -;; (parse 'tokens/bounds.2 "foo"))) -;; (is (equal '("foo(0-3)" "bar(4-7)" "quux(11-15)") -;; (parse 'tokens/bounds.2 "foo bar quux")))) +(test bounds.1 + (is (equal '("foo[0-3]") + (parse 'tokens/bounds.1 "foo"))) + (is (equal '("foo[0-3]" "bar[4-7]" "quux[11-15]") + (parse 'tokens/bounds.1 "foo bar quux")))) + +(test bounds.2 + (is (equal '("foo(0-3)") + (parse 'tokens/bounds.2 "foo"))) + (is (equal '("foo(0-3)" "bar(4-7)" "quux(11-15)") + (parse 'tokens/bounds.2 "foo bar quux")))) ;; (test condition.1 ;; "Test signaling of `esrap-simple-parse-error' conditions for failed From d7ba99bec924d23d9d3efd1fee29b25c61e538ce Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Fri, 8 Nov 2013 04:55:47 +0400 Subject: [PATCH 19/95] Fix greedy repetitions of zero-length-matching rules --- src/macro.lisp | 12 ++++++++---- tests/rules.lisp | 11 ++++++----- tests/tests.lisp | 7 ++++--- 3 files changed, 18 insertions(+), 12 deletions(-) diff --git a/src/macro.lisp b/src/macro.lisp index 4c1f275..a25b944 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -83,10 +83,14 @@ (defmacro! times (subexpr &key from upto exactly) (flet ((frob (condition) `(let (,g!-result) - (iter (let ((,g!-position (handler-case (let ((position position)) - (push ,subexpr ,g!-result) - position) - (simple-esrap-error () (terminate))))) + (iter (multiple-value-bind (,g!-subresult ,g!-position) + (handler-case (let ((position position)) + (values ,subexpr position)) + (simple-esrap-error () (terminate))) + (if-first-time nil + (if (equal ,g!-position position) + (terminate))) + (push ,g!-subresult ,g!-result) (setf position ,g!-position)) (finally (if ,condition (return (make-result (nreverse ,g!-result))) diff --git a/tests/rules.lisp b/tests/rules.lisp index c108fa3..449003e 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -158,12 +158,13 @@ ;; ;; Testing ambiguity when repetitioning possibly empty-string-match -;; (defrule spaces (* #\space) -;; (:lambda (lst) -;; (length lst))) +(defrule spaces () + (length (times #\space))) -;; (defrule greedy-pos-spaces (+ spaces)) -;; (defrule greedy-spaces (* spaces)) +(defrule greedy-pos-spaces () + (postimes spaces)) +(defrule greedy-spaces () + (times spaces)) ;; (defparameter separator #\space) diff --git a/tests/tests.lisp b/tests/tests.lisp index 625a21e..c62217e 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -152,9 +152,10 @@ ;; (multiple-value-list (parse '(evenp decimal) "123" :junk-allowed t))))) -;; (test ambiguous-greedy-repetitions -;; (is (equal '((3) nil) (multiple-value-list (parse 'greedy-spaces " ")))) -;; (is (equal '((3) nil) (multiple-value-list (parse 'greedy-pos-spaces " "))))) +;; TODO: I dunno, maybe I still should return NIL as a second value if parse succeeded without JUNK-ALLOWED? +(test ambiguous-greedy-repetitions + (is (equal '((3) 3) (multiple-value-list (parse 'greedy-spaces " ")))) + (is (equal '((3) 3) (multiple-value-list (parse 'greedy-pos-spaces " "))))) ;; (test dynamic-wrapping From 73930cfcece553afb541fd3314a30a2460148af6 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Fri, 8 Nov 2013 23:11:51 +0400 Subject: [PATCH 20/95] Add back CHARACTER-RANGES, test dynamic context wrapping. --- src/esrap.lisp | 24 ++++++++++++++++++++++++ src/macro.lisp | 15 +++++++++++---- src/package.lisp | 2 +- tests/rules.lisp | 38 +++++++++++++++++++++----------------- tests/tests.lisp | 10 +++++----- 5 files changed, 62 insertions(+), 27 deletions(-) diff --git a/src/esrap.lisp b/src/esrap.lisp index 36a90fa..d530f1b 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -38,6 +38,30 @@ are allowed only if JUNK-ALLOWED is true." (with-macro-character (#\" string-reader) (car (read-list-old stream token))))) +(defun esrap-character-ranges (char-reader) + (lambda (stream token) + (with-dispatch-macro-character (#\# #\\ char-reader) + `(character-ranges ,@(read-list-old stream token))))) + +(defmacro! character-ranges (&rest char-specs) + (macrolet ((fail () + `(error "Character range specification is either a character or list of 2 characters, but got ~a." + char-spec))) + (iter (for char-spec in char-specs) + (collect (cond ((characterp char-spec) `((char= ,g!-char ,char-spec) ,g!-char)) + ((consp char-spec) + (destructuring-bind (start-char end-char) char-spec + (if (and (characterp start-char) + (characterp end-char)) + `((and (>= (char-code ,g!-char) ,(char-code start-char)) + (<= (char-code ,g!-char) ,(char-code end-char))) + ,g!-char) + (fail)))) + (t (fail))) + into res) + (finally (return `(let ((,g!-char (descend-with-rule 'character nil))) + (cond ,@res + (t (fail-parse "Character ~s does not belong to specified range" ,g!-char))))))))) (defvar *indentation-hint-table* nil) diff --git a/src/macro.lisp b/src/macro.lisp index a25b944..68790cb 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -22,7 +22,8 @@ (with-dispatch-macro-character (#\# #\\ (esrap-char-reader char-reader)) (with-macro-character (#\" (esrap-string-reader string-reader)) (read-macrolet ((literal-char (esrap-literal-char-reader char-reader)) - (literal-string (esrap-literal-string-reader string-reader))) + (literal-string (esrap-literal-string-reader string-reader)) + (character-ranges (esrap-character-ranges char-reader))) (call-next-method))))) (let ((*variable-transformer* (lambda (sym) ;; KLUDGE to not parse lambda-lists in defrule args @@ -69,7 +70,9 @@ `(progn (let ((position position)) (handler-case ,expr (simple-esrap-error (e) nil) - (:no-error () (fail-parse "Clause under non-consuming negation succeeded.")))) + (:no-error (result &optional position) + (declare (ignore result position)) + (fail-parse "Clause under non-consuming negation succeeded.")))) (make-result t 0))) (defmacro !! (expr) @@ -77,8 +80,12 @@ `(progn (let ((position position)) (handler-case ,expr (simple-esrap-error (e) nil) - (:no-error () (fail-parse "Clause under non-consuming negation succeeded.")))) - (make-result (char text position) 1))) + (:no-error (result &optional position) + (declare (ignore result position)) + (fail-parse "Clause under consuming negation succeeded.")))) + (if (equal end position) + (fail-parse "Reached EOF while trying to consume character.") + (make-result (char text position) 1)))) (defmacro! times (subexpr &key from upto exactly) (flet ((frob (condition) diff --git a/src/package.lisp b/src/package.lisp index 0ddd6b0..632304a 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -11,7 +11,7 @@ (:shadowing-import-from #:rutils.string #:strcat) (:export #:enable-read-macro-tokens #:disable-read-macro-tokens - #:! #:? #:& #:~ #:<- #:-> #:!! #:times #:postimes #:pred #:progm #:cond-parse + #:! #:? #:& #:~ #:<- #:-> #:!! #:times #:postimes #:pred #:progm #:cond-parse #:character-ranges #:match-start #:match-end #:literal-string #:literal-char #:register-context diff --git a/tests/rules.lisp b/tests/rules.lisp index 449003e..3cb6539 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -154,7 +154,8 @@ ;; (list (cons 0 (cons start end)))))) ;; (call-transform)))) -;; (defrule character-range (character-ranges (#\a #\b) #\-)) +(defrule character-range () + (character-ranges (#\a #\b) #\-)) ;; ;; Testing ambiguity when repetitioning possibly empty-string-match @@ -166,27 +167,30 @@ (defrule greedy-spaces () (times spaces)) -;; (defparameter separator #\space) +;; Subtle bug here was caused by the fact, that SEPARATOR variable name +;; was the same as SEPARATOR rule-name. +(defparameter separator-char #\space) -;; (defrule simple-prefix (character-ranges (#\a #\z))) +(defrule simple-prefix () + (character-ranges (#\a #\z))) -;; (defun separator-p (x) -;; (and (characterp x) (char= x separator))) +(defun separator-p (x) + (and (characterp x) (char= x separator-char))) -;; (defrule separator (separator-p character)) +(defrule separator () + (pred #'separator-p character)) -;; (defrule word (+ (not separator)) -;; (:text t)) +(defrule not-separator () + (!! separator)) + +(defrule word () + (text (postimes (!! separator)))) -;; (defrule simple-wrapped (wrap simple-prefix -;; (and word -;; (* (and separator word)) -;; (? separator))) -;; (:wrap-around (let ((separator wrapper)) -;; (call-parser))) -;; (:destructure (word rest-words sep) -;; (declare (ignore sep)) -;; `(,word ,@(mapcar #'cadr rest-words)))) +(defrule simple-wrapped () + (let ((separator-char simple-prefix)) + (prog1 (cons word + (times (progn separator word))) + (? separator)))) ;; (defparameter dyna-from 3) ;; (defparameter dyna-to 5) diff --git a/tests/tests.lisp b/tests/tests.lisp index c62217e..8a5f95b 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -158,11 +158,11 @@ (is (equal '((3) 3) (multiple-value-list (parse 'greedy-pos-spaces " "))))) -;; (test dynamic-wrapping -;; (is (equal '(("oo" "oo" "oo") nil) -;; (multiple-value-list (parse 'simple-wrapped "foofoofoof")))) -;; (is (equal '(("oofoofoof") nil) -;; (multiple-value-list (parse 'simple-wrapped "goofoofoof"))))) +(test dynamic-wrapping + (is (equal '(("oo" "oo" "oo") 10) + (multiple-value-list (parse 'simple-wrapped "foofoofoof")))) + (is (equal '(("oofoofoof") 10) + (multiple-value-list (parse 'simple-wrapped "goofoofoof"))))) ;; (test dynamic-times ;; (is (equal '("aaaaa" "aaa") (parse 'dyna-from-tos "aaaaaaaa"))) From 2ffc49a039d799f55d61749e024cdafbd7bedb1f Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Sat, 9 Nov 2013 01:03:31 +0400 Subject: [PATCH 21/95] Enable some context sensitivity tests. Fix STRING rule. Fix TIMES rule. --- src/basic-rules.lisp | 5 ++++- src/macro.lisp | 6 ++++-- tests/rules.lisp | 38 ++++++++++++++++++++++++++------------ tests/tests.lisp | 27 +++++++++++++-------------- 4 files changed, 47 insertions(+), 29 deletions(-) diff --git a/src/basic-rules.lisp b/src/basic-rules.lisp index 1b8432f..7422b1b 100644 --- a/src/basic-rules.lisp +++ b/src/basic-rules.lisp @@ -30,7 +30,10 @@ (defrule string (string) (let ((any-string (any-string (length string)))) (if (string= any-string string) - (make-result any-string)))) + (make-result any-string) + (fail-parse (literal-string "String ~a is not equal to desired string ~a") + any-string + string)))) (defun joinl (joinee lst) (format nil (strcat "~{~a~^" joinee "~}") lst)) diff --git a/src/macro.lisp b/src/macro.lisp index 68790cb..569cc2c 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -90,10 +90,12 @@ (defmacro! times (subexpr &key from upto exactly) (flet ((frob (condition) `(let (,g!-result) - (iter (multiple-value-bind (,g!-subresult ,g!-position) + (iter ,(if (or upto exactly) + `(for ,g!-i from 1 to ,(or upto exactly))) + (multiple-value-bind (,g!-subresult ,g!-position) (handler-case (let ((position position)) (values ,subexpr position)) - (simple-esrap-error () (terminate))) + (simple-esrap-error () (finish))) (if-first-time nil (if (equal ,g!-position position) (terminate))) diff --git a/tests/rules.lisp b/tests/rules.lisp index 3cb6539..13f3ce6 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -162,6 +162,12 @@ (defrule spaces () (length (times #\space))) +(defrule three-spaces () + (length (times #\space :exactly 3))) + +(defrule upto-three-spaces () + (length (times #\space :upto 3))) + (defrule greedy-pos-spaces () (postimes spaces)) (defrule greedy-spaces () @@ -192,19 +198,27 @@ (times (progn separator word))) (? separator)))) -;; (defparameter dyna-from 3) -;; (defparameter dyna-to 5) +(defparameter dyna-from-times 3) +(defparameter dyna-to-times 5) -;; (defrule dyna-from-to (* dyna-from dyna-to "a") -;; (:text t)) +(defrule dyna-from-to () + (text (times "a" :from dyna-from-times :upto dyna-to-times))) + +(defrule dyna-from-tos () + (times dyna-from-to)) + +(defparameter context :void) -;; (defrule dyna-from-tos (* dyna-from-to)) +(defun in-context-p (x) + (declare (ignore x)) + (and context (not (eql context :void)))) -;; (defparameter context :void) +(defrule context-sensitive () + (pred #'in-context-p "")) +(defrule ooc-word () + word + (literal-string "out of context word")) -;; (defun in-context-p (x) -;; (declare (ignore x)) -;; (and context (not (eql context :void)))) -;; (defrule context (in-context-p "")) -;; (defrule ooc-word word -;; (:constant "out of context word")) +(defrule cond-word () + dyna-from-to + word) diff --git a/tests/tests.lisp b/tests/tests.lisp index 8a5f95b..a80a91d 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -164,20 +164,19 @@ (is (equal '(("oofoofoof") 10) (multiple-value-list (parse 'simple-wrapped "goofoofoof"))))) -;; (test dynamic-times -;; (is (equal '("aaaaa" "aaa") (parse 'dyna-from-tos "aaaaaaaa"))) -;; (is (equal '("aaaa" "aaaa") (let ((dyna-to 4)) -;; (parse 'dyna-from-tos "aaaaaaaa"))))) - -;; (defrule cond-word (cond (dyna-from-to word))) - -;; (test cond -;; (is (equal "foo" (parse 'cond-word "aaaafoo"))) -;; (is (equal "foo" (let ((context t)) (parse '(cond (context word)) "foo")))) -;; (is (equal :error-occured (handler-case (parse '(cond (context word)) "foo") -;; (error () :error-occured)))) -;; (is (equal "out of context word" (parse '(cond (context word) (t ooc-word)) -;; "foo")))) +(test dynamic-times + (is (equal '("aaaaa" "aaa") (parse 'dyna-from-tos "aaaaaaaa"))) + (is (equal '("aaaa" "aaaa") (let ((dyna-to-times 4)) + (parse 'dyna-from-tos "aaaaaaaa"))))) + +(test cond + (is (equal "foo" (parse 'cond-word "aaaafoo")))) + + ;; (is (equal "foo" (let ((context t)) (parse '(cond (context word)) "foo")))) + ;; (is (equal :error-occured (handler-case (parse '(cond (context word)) "foo") + ;; (error () :error-occured)))) + ;; (is (equal "out of context word" (parse '(cond (context word) (t ooc-word)) + ;; "foo")))) ;; (test followed-by-not-gen ;; (is (equal '("a" nil "b") (parse '(and "a" (-> "b") "b") "ab")))) From 0365c65c219d53201e6f24ded31f798ce6db41b6 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Sat, 9 Nov 2013 02:58:55 +0400 Subject: [PATCH 22/95] Towards temporary rules in PARSE --- src/macro.lisp | 46 +++++++++++++++++++++++++++++----------------- 1 file changed, 29 insertions(+), 17 deletions(-) diff --git a/src/macro.lisp b/src/macro.lisp index 569cc2c..5d9e572 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -16,29 +16,41 @@ (setf position new-position) result)))) -(defmacro!! defrule (name args &body body) - (let ((char-reader (get-dispatch-macro-character #\# #\\)) +(defmacro with-esrap-reader-context (&body body) + `(let ((char-reader (get-dispatch-macro-character #\# #\\)) (string-reader (get-macro-character #\"))) (with-dispatch-macro-character (#\# #\\ (esrap-char-reader char-reader)) (with-macro-character (#\" (esrap-string-reader string-reader)) (read-macrolet ((literal-char (esrap-literal-char-reader char-reader)) (literal-string (esrap-literal-string-reader string-reader)) (character-ranges (esrap-character-ranges char-reader))) - (call-next-method))))) - (let ((*variable-transformer* (lambda (sym) - ;; KLUDGE to not parse lambda-lists in defrule args - (if (equal "CHARACTER" (string sym)) - `(descend-with-rule 'character nil) - `(descend-with-rule ',sym))))) - `(setf (gethash ',name *rules*) - ,(macroexpand-all-transforming-undefs `(named-lambda ,(intern (strcat "ESRAP-" name)) (text position end ,@args) - (let ((,g!-position position)) - (declare (ignorable ,g!-position)) - (symbol-macrolet ((match-start ,g!-position) - (match-end position)) - (with-cached-result (,name position text ,@args) - (values (progn ,@body) - position))))))))) + ,@body))))) + +(defmacro with-esrap-variable-transformer (&body body) + `(let ((*variable-transformer* (lambda (sym) + ;; KLUDGE to not parse lambda-lists in defrule args + (if (equal "CHARACTER" (string sym)) + `(descend-with-rule 'character nil) + `(descend-with-rule ',sym))))) + ,@body)) + +(defun! install-rule (name args body) + `(setf (gethash ',name *rules*) + ,(macroexpand-all-transforming-undefs + `(named-lambda ,(intern (strcat "ESRAP-" name)) (text position end ,@args) + (let ((,g!-position position)) + (declare (ignorable ,g!-position)) + (symbol-macrolet ((match-start ,g!-position) + (match-end position)) + (with-cached-result (,name position text ,@args) + (values (progn ,@body) + position)))))))) + +(defmacro!! defrule (name args &body body) + (with-esrap-reader-context + (call-next-method)) + (with-esrap-variable-transformer + (install-rule name args body))) (defmacro! make-result (result &optional (length 0)) ;; We must preserve the semantics, that computation of results occurs before increment of position From 529ff157673b90400cef9456967c6714949c498c Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Sat, 9 Nov 2013 04:12:27 +0400 Subject: [PATCH 23/95] Make PARSE compile temporary top-level rule on the fly --- src/esrap.lisp | 35 +++++++++++++++++++++++------------ src/macro.lisp | 25 +++++++++++++------------ 2 files changed, 36 insertions(+), 24 deletions(-) diff --git a/src/esrap.lisp b/src/esrap.lisp index d530f1b..7bf44c1 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -8,20 +8,31 @@ ;;; MAIN INTERFACE -(defun parse (expression text &key (start 0) end junk-allowed) +(defun! parse (expression text &key (start 0) end junk-allowed) "Parses TEXT using EXPRESSION from START to END. Incomplete parses are allowed only if JUNK-ALLOWED is true." - ;; There is no backtracking in the toplevel expression -- so there's - ;; no point in compiling it as it will be executed only once -- unless - ;; it's a constant, for which we have a compiler-macro. - (let ((end (or end (length text))) - (position start) - (*cache* (make-cache))) - (let ((result (descend-with-rule expression))) - (if (and (not junk-allowed) - (not (equal end position))) - (fail-parse "Didnt make it to the end of the text") - (values result position))))) + (unwind-protect (progn (setf (gethash g!-tmp-rule *rules*) + (funcall (compile nil `(lambda () + ,(with-esrap-variable-transformer + (make-rule-lambda 'esrap-tmp-rule () + (list expression) + :null)))))) + ;; (format t "rule hash: ~a" (hash->assoc *rules*)) + (let ((end (or end (length text))) + (position start) + (*cache* (make-cache))) + (let ((result (descend-with-rule g!-tmp-rule))) + (if (and (not junk-allowed) + (not (equal end position))) + (fail-parse "Didnt make it to the end of the text") + (values result position))))) + (remhash g!-tmp-rule *rules*))) + +(define-read-macro parse + (let ((expression (with-esrap-reader-context + (read stream t nil t)))) + `(parse ,expression ,@(read-list-old stream token)))) + (defun esrap-char-reader (char-reader) (lambda (stream char subchar) diff --git a/src/macro.lisp b/src/macro.lisp index 5d9e572..c88e2ad 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -34,23 +34,24 @@ `(descend-with-rule ',sym))))) ,@body)) -(defun! install-rule (name args body) - `(setf (gethash ',name *rules*) - ,(macroexpand-all-transforming-undefs - `(named-lambda ,(intern (strcat "ESRAP-" name)) (text position end ,@args) - (let ((,g!-position position)) - (declare (ignorable ,g!-position)) - (symbol-macrolet ((match-start ,g!-position) - (match-end position)) - (with-cached-result (,name position text ,@args) - (values (progn ,@body) - position)))))))) +(defun! make-rule-lambda (name args body &optional (env :current)) + (macroexpand-all-transforming-undefs + `(named-lambda ,(intern (strcat "ESRAP-" name)) (text position end ,@args) + (let ((,g!-position position)) + (declare (ignorable ,g!-position)) + (symbol-macrolet ((match-start ,g!-position) + (match-end position)) + (with-cached-result (,name position text ,@args) + (values (progn ,@body) + position))))) + :o!-env env)) (defmacro!! defrule (name args &body body) (with-esrap-reader-context (call-next-method)) (with-esrap-variable-transformer - (install-rule name args body))) + `(setf (gethash ',name *rules*) + ,(make-rule-lambda name args body)))) (defmacro! make-result (result &optional (length 0)) ;; We must preserve the semantics, that computation of results occurs before increment of position From d1a27017e2cc27f11fce33ed0466a2f5178b1394 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Tue, 12 Nov 2013 23:22:28 +0400 Subject: [PATCH 24/95] Change name of system to ESRAP-LIQUID, add COPYING --- COPYING | 674 ++++++++++++++++++++++++++++++++++ esrap.asd => esrap-liquid.asd | 16 +- src/basic-rules.lisp | 2 +- src/conditions.lisp | 2 +- src/esrap.lisp | 2 +- src/macro.lisp | 2 +- src/memoization.lisp | 2 +- src/miscellany.lisp | 2 +- src/package.lisp | 2 +- src/rule-storage.lisp | 2 +- tests/package.lisp | 8 +- tests/rules.lisp | 2 +- tests/tests.lisp | 2 +- 13 files changed, 696 insertions(+), 22 deletions(-) create mode 100644 COPYING rename esrap.asd => esrap-liquid.asd (80%) diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..94a9ed0 --- /dev/null +++ b/COPYING @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/esrap.asd b/esrap-liquid.asd similarity index 80% rename from esrap.asd rename to esrap-liquid.asd index abccd07..a8ae626 100644 --- a/esrap.asd +++ b/esrap-liquid.asd @@ -5,12 +5,12 @@ ;;;; For licence details, see COPYING -(defpackage :esrap-system +(defpackage :esrap-liquid-system (:use :cl :asdf)) -(in-package :esrap-system) +(in-package :esrap-liquid-system) -(defsystem :esrap +(defsystem :esrap-liquid :version "1.1" ; odd minor version numbers are for unstable versions :description "A Packrat / Parsing Grammar / TDPL parser for Common Lisp." :licence "GPL" @@ -31,16 +31,16 @@ (:static-file "example-symbol-table.lisp") (:static-file "README"))) -(defsystem :esrap-tests - :description "Tests for ESRAP." +(defsystem :esrap-liquid-tests + :description "Tests for ESRAP-LIQUID." :licence "GPL" - :depends-on (#:esrap #:fiveam #:cl-interpol) + :depends-on (#:esrap-liquid #:fiveam #:cl-interpol) :serial t :pathname "tests/" :components ((:file "package") (:file "rules") (:file "tests"))) -(defmethod perform ((op test-op) (sys (eql (find-system :esrap)))) +(defmethod perform ((op test-op) (sys (eql (find-system :esrap-liquid)))) (load-system :esrap-tests) - (funcall (intern "RUN-TESTS" :esrap-tests))) + (funcall (intern "RUN-TESTS" :esrap-liquid-tests))) diff --git a/src/basic-rules.lisp b/src/basic-rules.lisp index 7422b1b..587d3a2 100644 --- a/src/basic-rules.lisp +++ b/src/basic-rules.lisp @@ -4,7 +4,7 @@ ;;;; Alexander Popolitov, 2013 ;;;; For licence, see COPYING -(in-package #:esrap) +(in-package #:esrap-liquid) (enable-read-macro-tokens) diff --git a/src/conditions.lisp b/src/conditions.lisp index c0e45df..de5409a 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -5,7 +5,7 @@ ;;;; For licence, see COPYING -(in-package :esrap) +(in-package :esrap-liquid) (define-condition esrap-error (parse-error) ((text :initarg :text :initform nil :reader esrap-error-text) diff --git a/src/esrap.lisp b/src/esrap.lisp index 7bf44c1..835e4e6 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -4,7 +4,7 @@ ;;;; Alexander Popolitov, 2013 ;;;; For licence, see COPYING -(in-package :esrap) +(in-package :esrap-liquid) ;;; MAIN INTERFACE diff --git a/src/macro.lisp b/src/macro.lisp index c88e2ad..295db18 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -4,7 +4,7 @@ ;;;; Alexander Popolitov, 2013 ;;;; For licence, see COPYING -(in-package #:esrap) +(in-package #:esrap-liquid) (defmacro! descend-with-rule (o!-sym &rest args) `(multiple-value-bind (,g!-it ,g!-got) (gethash ,o!-sym *rules*) diff --git a/src/memoization.lisp b/src/memoization.lisp index 6fac5d2..da092a8 100644 --- a/src/memoization.lisp +++ b/src/memoization.lisp @@ -4,7 +4,7 @@ ;;;; Alexander Popolitov, 2013 ;;;; For licence, see COPYING -(in-package :esrap) +(in-package :esrap-liquid) (defparameter contexts nil) (defmacro register-context (context-sym) diff --git a/src/miscellany.lisp b/src/miscellany.lisp index a5a5bdf..d892d9c 100644 --- a/src/miscellany.lisp +++ b/src/miscellany.lisp @@ -4,7 +4,7 @@ ;;;; Alexander Popolitov, 2013 ;;;; For licence, see COPYING -(in-package :esrap) +(in-package :esrap-liquid) (defun text (&rest arguments) "Arguments must be strings, or lists whose leaves are strings. diff --git a/src/package.lisp b/src/package.lisp index 632304a..f9f1b9b 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -6,7 +6,7 @@ (in-package #:cl-user) -(defpackage :esrap +(defpackage :esrap-liquid (:use #:cl #:alexandria #:defmacro-enhance #:iterate #:cl-indeterminism #:cl-read-macro-tokens) (:shadowing-import-from #:rutils.string #:strcat) (:export diff --git a/src/rule-storage.lisp b/src/rule-storage.lisp index 8cdff28..03193ec 100644 --- a/src/rule-storage.lisp +++ b/src/rule-storage.lisp @@ -4,7 +4,7 @@ ;;;; Alexander Popolitov, 2013 ;;;; For licence, see COPYING -(in-package :esrap) +(in-package :esrap-liquid) ;;; RULE REPRESENTATION AND STORAGE diff --git a/tests/package.lisp b/tests/package.lisp index 8bd34c8..12f72a1 100644 --- a/tests/package.lisp +++ b/tests/package.lisp @@ -7,12 +7,12 @@ (in-package :cl-user) -(defpackage :esrap-tests - (:use :alexandria :cl :esrap :fiveam) - (:shadowing-import-from :esrap "!" "!!") +(defpackage :esrap-liquid-tests + (:use :alexandria :cl :esrap-liquid :fiveam) + (:shadowing-import-from :esrap-liquid "!" "!!") (:export #:run-tests)) -(in-package :esrap-tests) +(in-package :esrap-liquid-tests) (defun run-tests () (let ((results (run 'esrap))) diff --git a/tests/rules.lisp b/tests/rules.lisp index 13f3ce6..f379f0c 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -5,7 +5,7 @@ ;;;; For licence, see COPYING -(in-package :esrap-tests) +(in-package :esrap-liquid-tests) (enable-read-macro-tokens) (cl-interpol:enable-interpol-syntax) diff --git a/tests/tests.lisp b/tests/tests.lisp index a80a91d..f0fd47e 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -4,7 +4,7 @@ ;;;; Alexander Popolitov, 2013 ;;;; For licence, see COPYING -(in-package :esrap-tests) +(in-package :esrap-liquid-tests) (enable-read-macro-tokens) (cl-interpol:enable-interpol-syntax) From 495d0630577cd6f1ae0e691b31618bb86299fbe8 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Thu, 14 Nov 2013 01:13:50 +0400 Subject: [PATCH 25/95] Make all but one test enabled and working --- src/esrap.lisp | 14 ++-- src/macro.lisp | 13 ++-- src/memoization.lisp | 21 ++++-- tests/rules.lisp | 63 ++++++++-------- tests/tests.lisp | 169 +++++++++++++++++++------------------------ 5 files changed, 136 insertions(+), 144 deletions(-) diff --git a/src/esrap.lisp b/src/esrap.lisp index 835e4e6..17f9038 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -21,11 +21,15 @@ are allowed only if JUNK-ALLOWED is true." (let ((end (or end (length text))) (position start) (*cache* (make-cache))) - (let ((result (descend-with-rule g!-tmp-rule))) - (if (and (not junk-allowed) - (not (equal end position))) - (fail-parse "Didnt make it to the end of the text") - (values result position))))) + (handler-case (let ((result (descend-with-rule g!-tmp-rule))) + (if (and (not junk-allowed) + (not (equal end position))) + (fail-parse "Didnt make it to the end of the text") + (values result position))) + (simple-esrap-error (e) + (if junk-allowed + (values nil start) + (error e)))))) (remhash g!-tmp-rule *rules*))) (define-read-macro parse diff --git a/src/macro.lisp b/src/macro.lisp index 295db18..52cf0b4 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -8,11 +8,11 @@ (defmacro! descend-with-rule (o!-sym &rest args) `(multiple-value-bind (,g!-it ,g!-got) (gethash ,o!-sym *rules*) - (format t "sym: ~a ~a~%" ,o!-sym position) + ;; (format t "sym: ~a ~a~%" ,o!-sym position) (if (not ,g!-got) (error "Undefined rule: ~s" ,o!-sym) (multiple-value-bind (result new-position) (funcall ,g!-it text position end ,@args) - (format t "position before setting ~a, after setting would be ~a" position new-position) + ;; (format t "position before setting ~a, after setting would be ~a" position new-position) (setf position new-position) result)))) @@ -67,6 +67,7 @@ (let (,g!-parse-errors) ,@(mapcar (lambda (clause) `(handler-case (let ((position position)) + ;; (format t "Im in ordered choice~%") (return-from ,g!-ordered-choice (values ,clause position))) (simple-esrap-error (e) (push e ,g!-parse-errors)))) clauses) @@ -82,7 +83,7 @@ "Succeeds, whenever parsing of EXPR fails. Does not consume." `(progn (let ((position position)) (handler-case ,expr - (simple-esrap-error (e) nil) + (simple-esrap-error () nil) (:no-error (result &optional position) (declare (ignore result position)) (fail-parse "Clause under non-consuming negation succeeded.")))) @@ -92,7 +93,7 @@ "Succeeds, whenever parsing of EXPR fails. Consumes, assumes than EXPR parses just one character." `(progn (let ((position position)) (handler-case ,expr - (simple-esrap-error (e) nil) + (simple-esrap-error () nil) (:no-error (result &optional position) (declare (ignore result position)) (fail-parse "Clause under consuming negation succeeded.")))) @@ -164,13 +165,13 @@ (defmacro! <- (subexpr) (if (and (symbolp subexpr) (equal (string subexpr) "SOF")) `(if (equal 0 position) - (make-result t) + (make-result nil) (fail-parse "not at start-of-file")) `(let ((,g!-old-position position) (position (1- position))) (let ((,g!-result ,subexpr)) (if (equal ,g!-old-position position) - (make-result ,g!-result) + (make-result nil) (fail-parse "Parsing of subexpr took more than 1 char.")))))) (defmacro! cond-parse (&rest clauses) diff --git a/src/memoization.lisp b/src/memoization.lisp index da092a8..f4caa29 100644 --- a/src/memoization.lisp +++ b/src/memoization.lisp @@ -18,8 +18,8 @@ (defun get-cached (symbol position args cache) (gethash `(,symbol ,position ,args ,@(mapcar #'symbol-value contexts)) cache)) -(defun (setf get-cached) (result symbol position cache) - (setf (gethash `(,symbol ,position ,@(mapcar #'symbol-value contexts)) cache) result)) +(defun (setf get-cached) (result symbol position args cache) + (setf (gethash `(,symbol ,position ,args ,@(mapcar #'symbol-value contexts)) cache) result)) (defvar *nonterminal-stack* nil) @@ -33,12 +33,16 @@ ;;; SYMBOL, POSITION, and CACHE must all be lexical variables! (defmacro! with-cached-result ((symbol position text &rest args) &body forms) `(let* ((,g!-cache *cache*) - (,g!-result (get-cached ',symbol ,position (list ,@args) ,g!-cache)) + (,g!-args (list ,@args)) + (,g!-position ,position) + (,g!-result (get-cached ',symbol ,g!-position ,g!-args ,g!-cache)) (*nonterminal-stack* (cons ',symbol *nonterminal-stack*))) + ;; (format t "hashassoc ~a~%" (hash->assoc ,g!-cache)) + ;; (format t "sym: ~a pos: ~a res: ~a~%" ',symbol ,g!-position ,g!-result) (cond ((eq :left-recursion ,g!-result) (error 'left-recursion :text ,text - :position ,position + :position ,g!-position :nonterminal ',symbol :path (reverse *nonterminal-stack*))) (,g!-result (if (failed-parse-p ,g!-result) @@ -47,14 +51,17 @@ (t ;; First mark this pair with :LEFT-RECURSION to detect left-recursion, ;; then compute the result and cache that. - (setf (get-cached ',symbol ,position ,g!-cache) :left-recursion) + (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) :left-recursion) + ;; (format t "hashassoc 2 ~a~%" (hash->assoc ,g!-cache)) (multiple-value-bind (result position) (handler-case (locally ,@forms) (simple-esrap-error (e) e)) ;; POSITION is non-NIL only for successful parses (if position - (progn (setf (get-cached ',symbol ,position ,g!-cache) + (progn (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) (cons result position)) + ;; (format t "hashassoc 2.5 ~a~%" (hash->assoc ,g!-cache)) (values result position)) - (progn (setf (get-cached ',symbol ,position ,g!-cache) + (progn (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) result) + ;; (format t "hashassoc 3 ~a~%" (hash->assoc ,g!-cache)) (error result)))))))) diff --git a/tests/rules.lisp b/tests/rules.lisp index f379f0c..6192293 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -120,39 +120,28 @@ (defrule left-recursion () (progn left-recursion "l")) -;; (declaim (special *depth*)) -;; (defvar *depth* nil) - -;; (defrule around/inner -;; (+ (alpha-char-p character)) -;; (:text t)) - -;; (defrule around.1 -;; (or around/inner -;; (and #\{ around.1 #\})) -;; (:lambda (thing) -;; (if (stringp thing) -;; (cons *depth* thing) -;; (second thing))) -;; (:around () -;; (let ((*depth* (if *depth* -;; (cons (1+ (first *depth*)) *depth*) -;; (list 0)))) -;; (call-transform)))) - -;; (defrule around.2 -;; (or around/inner -;; (and #\{ around.2 #\})) -;; (:lambda (thing) -;; (if (stringp thing) -;; (cons *depth* thing) -;; (second thing))) -;; (:around (&bounds start end) -;; (let ((*depth* (if *depth* -;; (cons (cons (1+ (car (first *depth*))) (cons start end)) -;; *depth*) -;; (list (cons 0 (cons start end)))))) -;; (call-transform)))) +(declaim (special *depth*)) +(defvar *depth* nil) + +(defrule around/inner () + (text (postimes (pred #'alpha-char-p character)))) + +(defrule around.1 () + (let ((*depth* (if *depth* + (cons (1+ (first *depth*)) *depth*) + (list 0)))) + (let ((it (|| around/inner + (list #\{ around.1 #\})))) + (if (stringp it) + (cons *depth* it) + (second it))))) + +(defrule around.2 () + (let ((it (|| around/inner + (progm #\{ around.2 #\})))) + (if (stringp it) + `(((0 . (,match-start . ,match-end))) . ,it) + `(((,(1+ (caaar it)) . (,match-start . ,match-end)) ,. (car it)) . ,(cdr it))))) (defrule character-range () (character-ranges (#\a #\b) #\-)) @@ -222,3 +211,11 @@ (defrule cond-word () dyna-from-to word) + +(defrule foo+ () + (postimes "foo")) + +(defrule decimal () + (parse-integer (format nil (literal-string "~{~A~}") + (postimes (|| "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))))) + diff --git a/tests/tests.lisp b/tests/tests.lisp index f0fd47e..898ba68 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -73,83 +73,69 @@ ;; "Encountered at")) ;; (parse 'list-of-integers "1, ")))) -;; (test condition.2 -;; "Test signaling of `left-recursion' condition." -;; (signals (left-recursion) -;; (parse 'left-recursion "l")) -;; (handler-case (parse 'left-recursion "l") -;; (left-recursion (condition) -;; (is (string= (esrap-error-text condition) "l")) -;; (is (= (esrap-error-position condition) 0)) -;; (is (eq (left-recursion-nonterminal condition) -;; 'left-recursion)) -;; (is (equal (left-recursion-path condition) -;; '(left-recursion left-recursion)))))) - -;; (test negation -;; "Test negation in rules." -;; (let* ((text "FooBazBar") -;; (t1c (text (parse '(+ (not "Baz")) text :junk-allowed t))) -;; (t1e (text (parse (identity '(+ (not "Baz"))) text :junk-allowed t))) -;; (t2c (text (parse '(+ (not "Bar")) text :junk-allowed t))) -;; (t2e (text (parse (identity '(+ (not "Bar"))) text :junk-allowed t))) -;; (t3c (text (parse '(+ (not (or "Bar" "Baz"))) text :junk-allowed t))) -;; (t3e (text (parse (identity '(+ (not (or "Bar" "Baz")))) text :junk-allowed t)))) -;; (is (equal "Foo" t1c)) -;; (is (equal "Foo" t1e)) -;; (is (equal "FooBaz" t2c)) -;; (is (equal "FooBaz" t2e)) -;; (is (equal "Foo" t3c)) -;; (is (equal "Foo" t3e)))) - -;; (test around.1 -;; "Test executing code around the transform of a rule." -;; (macrolet ((test-case (input expected) -;; `(is (equal (parse 'around.1 ,input) ,expected)))) -;; (test-case "foo" '((0) . "foo")) -;; (test-case "{bar}" '((1 0) . "bar")) -;; (test-case "{{baz}}" '((2 1 0) . "baz")))) - -;; (test around.2 -;; "Test executing code around the transform of a rule." -;; (macrolet ((test-case (input expected) -;; `(is (equal (parse 'around.2 ,input) ,expected)))) -;; (test-case "foo" '(((0 . (0 . 3))) -;; . "foo")) -;; (test-case "{bar}" '(((1 . (1 . 4)) -;; (0 . (0 . 5))) -;; . "bar")) -;; (test-case "{{baz}}" '(((2 . (2 . 5)) -;; (1 . (1 . 6)) -;; (0 . (0 . 7))) -;; . "baz")))) - -;; (test character-range-test -;; (is (equal '(#\a #\b) (parse '(* (character-ranges (#\a #\z) #\-)) "ab" :junk-allowed t))) -;; (is (equal '(#\a #\b) (parse '(* (character-ranges (#\a #\z) #\-)) "ab1" :junk-allowed t))) -;; (is (equal '(#\a #\b #\-) (parse '(* (character-ranges (#\a #\z) #\-)) "ab-" :junk-allowed t))) -;; (is (not (parse '(* (character-ranges (#\a #\z) #\-)) "AB-" :junk-allowed t))) -;; (is (not (parse '(* (character-ranges (#\a #\z) #\-)) "ZY-" :junk-allowed t))) -;; (is (equal '(#\a #\b #\-) (parse '(* character-range) "ab-cd" :junk-allowed t)))) - -;; (test examples-from-readme-test -;; (is (equal '("foo" nil) -;; (multiple-value-list (parse '(or "foo" "bar") "foo")))) -;; (is (eq 'foo+ (add-rule 'foo+ -;; (make-instance 'rule :expression '(+ "foo"))))) -;; (is (equal '(("foo" "foo" "foo") nil) -;; (multiple-value-list (parse 'foo+ "foofoofoo")))) -;; (is (eq 'decimal -;; (add-rule 'decimal -;; (make-instance 'rule -;; :expression `(+ (or "0" "1" "2" "3" "4" "5" "6" "7" -;; "8" "9")) -;; :transform (lambda (list start end) -;; (declare (ignore start end)) -;; (parse-integer (format nil "~{~A~}" list))))))) -;; (is (eql 123 (parse '(oddp decimal) "123"))) -;; (is (equal '(nil 0) -;; (multiple-value-list (parse '(evenp decimal) "123" :junk-allowed t))))) +(test condition.2 + "Test signaling of `left-recursion' condition." + (signals (esrap-liquid::left-recursion) + (parse 'left-recursion "l")) + (handler-case (parse 'left-recursion "l") + (esrap-liquid::left-recursion (condition) + (is (string= (esrap-liquid::esrap-error-text condition) "l")) + (is (= (esrap-liquid::esrap-error-position condition) 0)) + (is (eq (esrap-liquid::left-recursion-nonterminal condition) + 'left-recursion)) + (is (equal (esrap-liquid::left-recursion-path condition) + '(esrap-liquid::esrap-tmp-rule left-recursion left-recursion)))))) + +(test negation + "Test negation in rules." + (let* ((text "FooBazBar") + (t1c (text (parse '(postimes (!! "Baz")) text :junk-allowed t))) + (t1e (text (parse '(pred #'identity (postimes (!! "Baz"))) text :junk-allowed t))) + (t2c (text (parse '(postimes (!! "Bar")) text :junk-allowed t))) + (t2e (text (parse '(pred #'identity (postimes (!! "Bar"))) text :junk-allowed t))) + (t3c (text (parse '(postimes (!! (|| "Bar" "Baz"))) text :junk-allowed t))) + (t3e (text (parse '(pred #'identity (postimes (!! (|| "Bar" "Baz")))) text :junk-allowed t)))) + (is (equal "Foo" t1c)) + (is (equal "Foo" t1e)) + (is (equal "FooBaz" t2c)) + (is (equal "FooBaz" t2e)) + (is (equal "Foo" t3c)) + (is (equal "Foo" t3e)))) + + +(test around.1 "Test executing code around the transform of a rule." + (is (equal '((0) . "foo") (parse 'around.1 "foo"))) + (is (equal '((1 0) . "bar") (parse 'around.1 "{bar}"))) + (is (equal '((2 1 0) . "baz") (parse 'around.1 "{{baz}}")))) + +(test around.2 + "Test executing code around the transform of a rule." + (is (equal '(((0 . (0 . 3))) . "foo") (parse 'around.2 "foo"))) + (is (equal '(((1 . (0 . 5)) + (0 . (1 . 4))) . "bar") (parse 'around.2 "{bar}"))) + (is (equal '(((2 . (0 . 7)) + (1 . (1 . 6)) + (0 . (2 . 5))) + . "baz") (parse 'around.2 "{{baz}}")))) + +(test character-range-test + (is (equal '(#\a #\b) (parse '(times (character-ranges (#\a #\z) #\-)) "ab" :junk-allowed t))) + (is (equal '(#\a #\b) (parse '(times (character-ranges (#\a #\z) #\-)) "ab1" :junk-allowed t))) + (is (equal '(#\a #\b #\-) (parse '(times (character-ranges (#\a #\z) #\-)) "ab-" :junk-allowed t))) + (is (equal nil (parse '(times (character-ranges (#\a #\z) #\-)) "AB-" :junk-allowed t))) + (is (equal nil (parse '(times (character-ranges (#\a #\z) #\-)) "ZY-" :junk-allowed t))) + (is (equal '(#\a #\b #\-) (parse '(times character-range) "ab-cd" :junk-allowed t)))) + + +(test examples-from-readme-test + (is (equal '("foo" 3) + (multiple-value-list (parse '(|| "foo" "bar") "foo")))) + (is (equal '(("foo" "foo" "foo") 9) + (multiple-value-list (parse 'foo+ "foofoofoo")))) + (is (eql 123 (parse '(pred #'oddp decimal) "123"))) + (is (equal '(nil 0) + (multiple-value-list (parse '(pred #'evenp decimal) "123" :junk-allowed t))))) + ;; TODO: I dunno, maybe I still should return NIL as a second value if parse succeeded without JUNK-ALLOWED? @@ -170,20 +156,17 @@ (parse 'dyna-from-tos "aaaaaaaa"))))) (test cond - (is (equal "foo" (parse 'cond-word "aaaafoo")))) - - ;; (is (equal "foo" (let ((context t)) (parse '(cond (context word)) "foo")))) - ;; (is (equal :error-occured (handler-case (parse '(cond (context word)) "foo") - ;; (error () :error-occured)))) - ;; (is (equal "out of context word" (parse '(cond (context word) (t ooc-word)) - ;; "foo")))) - -;; (test followed-by-not-gen -;; (is (equal '("a" nil "b") (parse '(and "a" (-> "b") "b") "ab")))) - -;; (test preceded-by-not-gen -;; (is (equal '("a" nil "b") (parse '(and "a" (<- "a") "b") "ab")))) - -;; (test on-the-fly-tagging -;; (is (equal '(:simple-tag "aaa") (parse '(tag :simple-tag "aaa") "aaa")))) + (is (equal "foo" (parse 'cond-word "aaaafoo"))) + (is (equal "foo" (let ((context t)) (parse '(progn context-sensitive word) "foo")))) + (is (equal :error-occured (handler-case (parse '(progn context-sensitive word) "foo") + (error () :error-occured)))) + (is (equal "out of context word" (parse '(|| (progn context-sensitive word) + ooc-word) + "foo")))) + +(test followed-by-not-gen + (is (equal '("a" nil "b") (parse '(list "a" (-> "b") "b") "ab")))) + +(test preceded-by-not-gen + (is (equal '("a" nil "b") (parse '(list "a" (<- "a") "b") "ab")))) From 1c2fea1bf8bca0b3b970f927473ed444e5f383d0 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Thu, 14 Nov 2013 01:26:39 +0400 Subject: [PATCH 26/95] Enable and correct the last test --- tests/tests.lisp | 52 ++++++++++++++++++++++++------------------------ 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/tests/tests.lisp b/tests/tests.lisp index 898ba68..aadd5df 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -46,32 +46,32 @@ (is (equal '("foo(0-3)" "bar(4-7)" "quux(11-15)") (parse 'tokens/bounds.2 "foo bar quux")))) -;; (test condition.1 -;; "Test signaling of `esrap-simple-parse-error' conditions for failed -;; parses." -;; (macrolet -;; ((signals-esrap-error ((input position &optional messages) &body body) -;; `(progn -;; (signals (esrap-error) -;; ,@body) -;; (handler-case (progn ,@body) -;; (esrap-error (condition) -;; (is (string= (esrap-error-text condition) ,input)) -;; (is (= (esrap-error-position condition) ,position)) -;; ,@(when messages -;; `((let ((report (princ-to-string condition))) -;; ,@(mapcar (lambda (message) -;; `(is (search ,message report))) -;; (ensure-list messages)))))))))) -;; (signals-esrap-error ("" 0 ("Could not parse subexpression" -;; "Encountered at")) -;; (parse 'integer "")) -;; (signals-esrap-error ("123foo" 3 ("Could not parse subexpression" -;; "Encountered at")) -;; (parse 'integer "123foo")) -;; (signals-esrap-error ("1, " 1 ("Incomplete parse." -;; "Encountered at")) -;; (parse 'list-of-integers "1, ")))) +(defmacro signals-esrap-error ((input position &optional messages) &body body) + `(progn + (signals (esrap-liquid::esrap-error) + ,@body) + (handler-case (progn ,@body) + (esrap-liquid::esrap-error (condition) + (is (string= (esrap-liquid::esrap-error-text condition) ,input)) + (is (= (esrap-liquid::esrap-error-position condition) ,position)) + ,@(when messages + `((let ((report (princ-to-string condition))) + ,@(mapcar (lambda (message) + `(is (search ,message report))) + (ensure-list messages))))))))) + +(test condition.1 + "Test signaling of `esrap-simple-parse-error' conditions for failed + parses." + (signals-esrap-error ("" 0 ("Greedy repetition failed" + "Encountered at")) + (parse 'integer "")) + (signals-esrap-error ("123foo" 3 ("Clause under non-consuming negation succeeded" + "Encountered at")) + (parse 'integer "123foo")) + (signals-esrap-error ("1, " 1 ("Didnt make it to the end of the text" + "Encountered at")) + (parse 'list-of-integers "1, "))) (test condition.2 "Test signaling of `left-recursion' condition." From 5ff2151271b87adedfbb6acbaf121b0eadfbb478 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Thu, 14 Nov 2013 03:11:59 +0400 Subject: [PATCH 27/95] Rewrite README, so it corresponds to new state of things --- README | 115 ------------------------------- README.md | 199 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 199 insertions(+), 115 deletions(-) delete mode 100644 README create mode 100644 README.md diff --git a/README b/README deleted file mode 100644 index da7931d..0000000 --- a/README +++ /dev/null @@ -1,115 +0,0 @@ -ESRAP -- a packrat parser for Common Lisp - -This branch attempts to intergrate DEFRULE macro and COMPILE-EXPRESSION and EVAL-EXPRESSION functions -into a single macro, where no manual code-walking is done and all the wisardy is done through -MACROLET and SYMBOL-MACROLET's and the like. -I hope, that it will allow to write a code that's more flexible, hence the name of the branch - liquid. - -In addition to regular Packrat / Parsing Grammar / TDPL features ESRAP -supports: - - - dynamic redefinition of nonterminals - - inline grammars - - semantic predicates - - introspective facilities (describing grammars, tracing, setting breaks) - -Homepage & Documentation: - - http://nikodemus.github.com/esrap/ - -References: - - * Bryan Ford, 2002, "Packrat Parsing: a Practical Linear Time - Algorithm with Backtracking". - - http://pdos.csail.mit.edu/~baford/packrat/thesis/ - -Licence: - - Copyright (c) 2007-2013 Nikodemus Siivola - - Permission is hereby granted, free of charge, to any person - obtaining a copy of this software and associated documentation files - (the "Software"), to deal in the Software without restriction, - including without limitation the rights to use, copy, modify, merge, - publish, distribute, sublicense, and/or sell copies of the Software, - and to permit persons to whom the Software is furnished to do so, - subject to the following conditions: - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY - CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, - TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE - SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -Syntax overview: - - -- case-sensitive terminal - (~ ) -- case-insensitive terminal - character -- any single character - (string length) -- any string of length - (not expression) -- complement of expression - (character-ranges ranges) -- character ranges - (and &rest sequence) - (or &rest ordered-choices) - (* [[from] to] greedy-repetition) - (+ greedy-positive-repetition) - (? optional) - (& followed-by) -- does not consume - (-> followed-by-not-gen) -- does not consume, produces NIL - (<- preceded-by-not-gen) -- succeeds, if preceeded by something of length 1, produces NIL - (! not-followed-by) -- does not consume - (cond &rest clauses) -- very analogous to CL's cond statement - (first expr) -- results in CAR of EXPR, if EXPR parses successfully - (tag tag-kwd expr) -- on the fly tagging of expression - ( expr) -- semantic parsing - - FROM and TO in (* ...) form may be arbitrary forms (e.g. special variables), but use with caution - - feature is experimental and probably does not handle local environment correctly. - - Each clause in COND form is of the form (PREDICATE-SUBEXPR VALUE-SUBEXPR). Clauses are executed in order. - First clause, for which PREDICATE-SUBEXPR succeeds and VALUE-SUBEXPR also succeeds, leads VALUE-SUBEXPR. - Tag-clause succeeds, whenever EXPR succeeds, and leads `(,TAG-KWD ,EXPR). It is useful to track, which - alternative of the ordered choice, indeed, realized, like that: - - (or (tag :simple simple-string) - (tag :complex complex-string)) - - without the need of introduction two additional named rules TAGGED-SIMPLE-STRING and TAGGED-COMPLEX-STRING. - - See file example-sexp.lisp for a complete sample grammar and usage, - example-symbol-table.lisp for a grammar with lexical scope, - example-very-context-sensitive.lisp for more complex example of context-sensitive grammar, - and tests.lisp for various rather trivial use-cases. - Also, package CL-YACLYAML uses all advanced facilities of this parser-generator extensively - so, see code there for - real-life examples. - -Trivial examples: - - ;; Parse takes a expression - (parse '(or "foo" "bar") "foo") => "foo", NIL - - ;; New rules can be added. - ;; - ;; Normally you'd use the declarative DEFRULE interface to define new - ;; rules, but everything it does can be done directly by building - ;; instances of the RULE class and using ADD-RULE to activate them. - (add-rule 'foo+ (make-instance 'rule :expression '(+ "foo"))) => FOO+ - - (parse 'foo+ "foofoofoo") => ("foo" "foo" "foo"), NIL - - ;; Rules can transform their matches. - (add-rule 'decimal - (make-instance 'rule - :expression '(+ (or "0" "1" "2" "3" "4" "5" "6" "7" "8" "9")) - :transform (lambda (list start end) - (declare (ignore start end)) - (parse-integer (format nil "~{~A~}" list))))) - => DECIMAL - - ;; Any lisp function can be used as a semantic predicate. - (parse '(oddp decimal) "123") => 123 - - (parse '(evenp decimal) "123" :junk-allowed t) => NIL, 0 diff --git a/README.md b/README.md new file mode 100644 index 0000000..0a32392 --- /dev/null +++ b/README.md @@ -0,0 +1,199 @@ +ESRAP-LIQUID +============ + +Why shouldn't I use full Common Lisp while defining packrat parser rules? + +It originated as a fork of ESRAP by Nikodemus Siivola (https://github.com/nikodemus/esrap), +but I quickly realized, that changes I wanted to make are so numerous, that in fact +it should be a separate project. + +Original idea is in this article: + + * Bryan Ford, 2002, "Packrat Parsing: a Practical Linear Time + Algorithm with Backtracking". + + http://pdos.csail.mit.edu/~baford/packrat/thesis/ + +What irked me is ESRAP: + - poor support of context-sensitive grammars (I was trying to implement parsing of YAML) + - specifically, when caching, context was not taken into considerations + - interface for defining rules was very rigid: defining of a syntactic structure of a rule + was done in a very limited DSL, extension of which required hacking of ESRAP itself + - when I started hacking ESRAP few more subtle things occured to me: + - custom codewalker was implemented to account for special syntax sugar + - due to this fact, compiler macros had to be used to obtain reasonable speed,n + which in turn prevented to define e.g. package-local rules. + +That said, I started this project in an attempt to fix some of those drawbacks, +mainly, rigidity, hence the name suffix "LIQUID". + +What it has now: + - full support of context sensitivity: you can 'register' variables, which store the context, + and their value is taken into account, while caching results + - no limited duplication of codewalking - to give characters, strings and symbols, that define rules, + 'special' meaning, CL-READ-MACRO-TOKENS is used; + hence, ability to use *whole* CL, while defining rules - ESRAP-LIQUID is a 'proper' deformation of CL + - definition of a rule is not split into separate syntactic part (which can fail) and semantic part + (which cannot fail and may contain costly operations). + It is due to you, the writer, to perform costly operations in the end of rule flow, if you so wish + - rules may depend on additional arguments (such as CHARACTER rule, which has optional parameter, + that specifies, which character it matches). + That said, syntax of DEFRULE is now pretty much like syntax of DEFUN + +What's not yet done: + - introspection features (description of a grammar) + - case-insensitive terminals + +Usage is best illustrated by examples, so here they are. For more examples, +see example-sexp.lisp, example-symbol-table.lisp, example-very-context-sensitive.lisp. +For even more real-life examples see my YAML parser https://github.com/mabragor/cl-yaclyaml. +It makes extensive use of features, not found in original ESRAP and it would be very hard to +implement otherwise. + +```lisp +; plain characters match to precisely that character in text +ESRAP-LIQUID> (parse '#\a "a") +#\a +1 +ESRAP-LIQUID> (parse '#\a "b") +#. +``` + +```lisp +; same goes for plain strings +ESRAP-LIQUID> (parse '"foo" "foo") +"foo" +3 +ESRAP-LIQUID> (parse '"foo" "bar") +#. +``` + +```lisp +; CHARACTER matches any single character +ESRAP-LIQUID> (parse 'character "a") +#\a +1 +ESRAP-LIQUID> (parse 'character "b") +#\b +1 +``` + +```lisp +; (ANY-STRING ) matches any string of a given length character +ESRAP-LIQUID> (parse '(any-string 3) "foo") +"foo" +3 +ESRAP-LIQUID> (parse '(any-string 3) "bar") +"bar" +3 +ESRAP-LIQUID> (parse '(any-string 3) "caboom!") +#. +``` + +```lisp +; (!! ) matches, whenever EXPR fails and consumes one character +ESRAP-LIQUID> (parse '(!! "foo") "bar" :junk-allowed t) +#\b +1 +ESRAP-LIQUID> (parse '(!! "foo") "foo") +#. +``` + +```lisp +; (|| &rest ) is an ordered choice, matches, whenever one of EXPRS succeeds, and outputs it +ESRAP-LIQUID> (parse '(|| #\a #\b) "a") +#\a +1 +ESRAP-LIQUID> (parse '(|| #\a #\b) "b") +#\a +1 +ESRAP-LIQUID> (parse '(|| #\a #\b) "c") +#. +``` + +```lisp +; (times &key from upto exactly) greedy matches expression multiple times, returns values as a list. +; If :UPTO or :EXACTLY is given, then consumes only that much exprs, even if there are more +; if :FROM is given, fails if consumed less than :FROM expressions +ESRAP-LIQUID> (parse '(times #\a) "") +NIL +0 +ESRAP-LIQUID> (parse '(times #\a) "aaa") +(#\a #\a #\a) +3 +ESRAP-LIQUID> (parse '(times #\a :exactly 6) "aaaaaa") +(#\a #\a #\a #\a #\a #\a) +6 +ESRAP-LIQUID> (parse '(times #\a :exactly 6) "aaa") +#. +``` + +```lisp +; (postimes ) is an alias for (times :from 1) +ESRAP-LIQUID> (parse '(postimes #\a) "") +#. +ESRAP-LIQUID> (parse '(postimes #\a) "aaa") +(#\a #\a #\a) +3 +``` + +```lisp +; (? ) returns result of parsing of EXPR, when parsing succeeds, and NIL otherwise, does not fail +ESRAP-LIQUID> (parse '(? #\a) "") +NIL +0 +ESRAP-LIQUID> (parse '(? #\a) "a") +#\a +1 +``` + +Other operators, defined by ESRAP-LIQUID, include: + (character-ranges ranges) -- character ranges + (& followed-by) -- does not consume + (-> followed-by-not-gen) -- does not consume, produces NIL + (<- preceded-by-not-gen) -- succeeds, if preceeded by something of length 1, produces NIL + (! not-followed-by) -- does not consume + (pred #' expr) -- semantic parsing + + +Typical idioms: + +```lisp +; succeed, when all subexpressions succeed, return list of those subexpressions +ESRAP-LIQUID> (parse '(list #\a #\b #\c) "abc") +(#\a #\b #\c) +3 +; succeed, when all subexpression succeed, return only last subexpression +ESRAP-LIQUID> (parse '(progn #\a #\b #\c) "abc") +#\c +3 +; succeed, when all subexpression succeed, return only first subexpression +ESRAP-LIQUID> (parse '(prog1 #\a #\b #\c) "abc") +#\a +3 +``` + +Defining rules +-------------- + +Of course, if you could only write one-liners with PARSE, it won't be interesting at all +So, you can define new rules using DEFRULE macro. + +```lisp +ESRAP-LIQUID> (defrule foo+ () + (postimes "foo")) +ESRAP-LIQUID> (parse 'foo+ "foofoofoo") +("foo" "foo" "foo") +``` + +```lisp +; simple arguments to rules are also possible +ESRAP-LIQUID> (defrule foo-times (times) + (times "foo" :exactly times)) +ESRAP-LIQUID> (parse '(descend-with-rule 'foo-times 3) "foofoofoo") +("foo" "foo" "foo") +ESRAP-LIQUID> (parse '(descend-with-rule 'foo-times 4) "foofoofoo") +#. +``` + +OK, that's all for this first readme version. From b85ac1b3c7f1c8d91aced0e001716cd4826926a6 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Fri, 15 Nov 2013 02:31:58 +0400 Subject: [PATCH 28/95] Integrate PARSE into DEFMACRO inheritance framework --- src/esrap.lisp | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/src/esrap.lisp b/src/esrap.lisp index 17f9038..ed900d6 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -32,10 +32,21 @@ are allowed only if JUNK-ALLOWED is true." (error e)))))) (remhash g!-tmp-rule *rules*))) -(define-read-macro parse - (let ((expression (with-esrap-reader-context - (read stream t nil t)))) - `(parse ,expression ,@(read-list-old stream token)))) +;; Read behaviour of PARSE is different from that of usual reader macros, +;; but we want to DEFMACRO!! also capture it, hence define new reader class +(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass parse-reader-class (cl-read-macro-tokens::tautological-read-macro-token) ()) + (defmethod read-handler ((obj parse-reader-class) stream token) + (let ((expression (with-esrap-reader-context + (read stream t nil t)))) + `(,(slot-value obj 'cl-read-macro-tokens::name) ,expression ,@(read-list-old stream token)))) + (setf (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-classes*) 'parse-reader-class + (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-instances*) (make-instance 'parse-reader-class + :name 'parse)) + (setf (gethash 'parse *read-macro-tokens*) + (lambda (stream token) + (read-handler (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-instances*) + stream token)))) (defun esrap-char-reader (char-reader) From 9e52720fe3bf74452dc54c75fe51384b9afa0150 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Fri, 15 Nov 2013 03:18:13 +0400 Subject: [PATCH 29/95] Add esrap environments --- README.md | 10 +++++- esrap-liquid.asd | 4 ++- src/esrap-env.lisp | 77 ++++++++++++++++++++++++++++++++++++++++++++++ src/package.lisp | 1 + tests/macro.lisp | 7 +++++ tests/rules.lisp | 7 +++++ tests/tests.lisp | 6 ++++ 7 files changed, 110 insertions(+), 2 deletions(-) create mode 100644 src/esrap-env.lisp create mode 100644 tests/macro.lisp diff --git a/README.md b/README.md index 0a32392..8df1b4c 100644 --- a/README.md +++ b/README.md @@ -196,4 +196,12 @@ ESRAP-LIQUID> (parse '(descend-with-rule 'foo-times 4) "foofoofoo") #. ``` -OK, that's all for this first readme version. +Defining esrap-environments +--------------------------- + +To be written, main macro are: DEFINE-ESRAP-ENV and IN-ESRAP-ENV +Grep tests in order to see basic usage. + +The feature is needed, if you want to define rules not in global *RULES* variable (the default), +but instead in local 'environment' variable. This way you may have several non-colliding sets +of rules defined at the same time. diff --git a/esrap-liquid.asd b/esrap-liquid.asd index a8ae626..b016028 100644 --- a/esrap-liquid.asd +++ b/esrap-liquid.asd @@ -26,7 +26,8 @@ (:file "rule-storage") (:file "macro") (:file "esrap") - (:file "basic-rules"))) + (:file "basic-rules") + (:file "esrap-env"))) (:static-file "example-sexp.lisp") (:static-file "example-symbol-table.lisp") (:static-file "README"))) @@ -38,6 +39,7 @@ :serial t :pathname "tests/" :components ((:file "package") + (:file "macro") (:file "rules") (:file "tests"))) diff --git a/src/esrap-env.lisp b/src/esrap-env.lisp new file mode 100644 index 0000000..612db88 --- /dev/null +++ b/src/esrap-env.lisp @@ -0,0 +1,77 @@ +;;;; esrap-env.lisp + +;;;; This is a part of esrap-liquid TDPL for Common Lisp +;;;; Alexander Popolitov, 2013 +;;;; For licence, see COPYING + +(in-package :esrap-liquid) + +(defmacro! in-esrap-env (symbol) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro!! ,e!-define-rule (symbol args &body body) + () + `(,',(if symbol + (sb-int:symbolicate "DEFINE-" symbol "-RULE") + 'defrule) + ,symbol ,args ,@body)))) + +(defmacro define-esrap-env (symbol) + `(progn (eval-when (:compile-toplevel :load-toplevel :execute) + (defvar ,(sb-int:symbolicate symbol "-RULES") (make-hash-table)) + (defvar ,(sb-int:symbolicate symbol "-CONTEXTS") nil)) + (defmacro ,(sb-int:symbolicate "WITH-" symbol "-RULES") (&body body) + `(let ((esrap-liquid::*rules* ,',(sb-int:symbolicate symbol "-RULES"))) + ,@body)) + (defmacro ,(sb-int:symbolicate "WITH-" symbol "-CONTEXTS") (&body body) + `(let ((esrap-liquid::contexts ,',(sb-int:symbolicate symbol "-CONTEXTS"))) + ,@body)) + (defmacro!! ,(sb-int:symbolicate "DEFINE-" symbol "-RULE") (symbol args &body body) + () + `(,',(sb-int:symbolicate "WITH-" symbol "-RULES") + (,',(sb-int:symbolicate "WITH-" symbol "-CONTEXTS") + (defrule ,symbol ,args ,@body)))) + (defmacro ,(sb-int:symbolicate "REGISTER-" symbol "-CONTEXT") + (context-var &rest plausible-contexts) + `(progn (defparameter ,context-var ,(sb-int:keywordicate (format nil "~a" (car plausible-contexts)))) + ,@(mapcar (lambda (context-name) + (let ((pred-name (sb-int:symbolicate context-name + "-" + context-var + "-P")) + (rule-name (sb-int:symbolicate context-name + "-" + context-var))) + `(progn + (defun ,pred-name (x) + (declare (ignore x)) + (equal ,context-var ,(sb-int:keywordicate context-name))) + (,(sb-int:symbolicate 'define-rule) ,rule-name (,pred-name "") + (:constant nil))))) + (mapcar (lambda (x) (format nil "~a" x)) plausible-contexts)) + (push ',context-var ,',(sb-int:symbolicate symbol "-CONTEXTS")))) + (defmacro!! ,(sb-int:symbolicate symbol "-PARSE") + (expression text &key (start nil start-p) + (end nil end-p) + (junk-allowed nil junk-allowed-p)) + () + `(,',(sb-int:symbolicate "WITH-" symbol "-RULES") + (,',(sb-int:symbolicate "WITH-" symbol "-CONTEXTS") + (parse ,(if (and (consp expression) + (eql (car expression) 'quote) + (equal (length expression) 2) + (symbolp (cadr expression)) + (not (keywordp (cadr expression)))) + `',(intern (string (cadr expression)) + ',*package*) + expression) + ,text + ,@(if start-p `(:start ,start)) + ,@(if end-p `(:end ,end)) + ,@(if junk-allowed-p + `(:junk-allowed ,junk-allowed)))))))) + + + +;; This is the example of macroexpansion +#+nil +(define-esrap-env yaclyaml) diff --git a/src/package.lisp b/src/package.lisp index f9f1b9b..49765b5 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -19,4 +19,5 @@ #:defrule #:descend-with-rule #:any-string #:character #:string #:|| #:parse #:text + #:define-esrap-env #:in-esrap-env )) diff --git a/tests/macro.lisp b/tests/macro.lisp new file mode 100644 index 0000000..371ac34 --- /dev/null +++ b/tests/macro.lisp @@ -0,0 +1,7 @@ +(in-package :esrap-liquid-tests) + +(enable-read-macro-tokens) +(cl-interpol:enable-interpol-syntax) + +(define-esrap-env foo) +(define-esrap-env bar) diff --git a/tests/rules.lisp b/tests/rules.lisp index 6192293..71a0566 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -219,3 +219,10 @@ (parse-integer (format nil (literal-string "~{~A~}") (postimes (|| "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))))) +;;; Here we test correctness of defininion of parsing environments + +(define-foo-rule abracadabra () + (literal-string "foo")) + +(define-bar-rule abracadabra () + (literal-string "bar")) diff --git a/tests/tests.lisp b/tests/tests.lisp index aadd5df..f818b0b 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -170,3 +170,9 @@ (test preceded-by-not-gen (is (equal '("a" nil "b") (parse '(list "a" (<- "a") "b") "ab")))) + +(test esrap-env + (is (equal "foo" (foo-parse 'abracadabra ""))) + (is (equal "bar" (bar-parse 'abracadabra ""))) + (signals (esrap-liquid::simple-error) + (parse 'abracadabra ""))) From bfee87204f97269df5d0baa5a4f0870dde935d9e Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Mon, 18 Nov 2013 05:06:01 +0400 Subject: [PATCH 30/95] Adapt example-sexp.lisp to liquid esrap --- example-sexp.lisp | 79 +++++++++++++++++++++++++---------------------- 1 file changed, 42 insertions(+), 37 deletions(-) diff --git a/example-sexp.lisp b/example-sexp.lisp index 9a5f626..37f3653 100644 --- a/example-sexp.lisp +++ b/example-sexp.lisp @@ -1,12 +1,14 @@ ;;;; Esrap example: a simple S-expression grammar -(require :esrap) +(require :esrap-liquid) (defpackage :sexp-grammar - (:use :cl :esrap)) + (:use :cl :esrap-liquid)) (in-package :sexp-grammar) +(enable-read-macro-tokens) + ;;; A semantic predicate for filtering out double quotes. (defun not-doublequote (char) @@ -18,46 +20,49 @@ ;;; Utility rules. -(defrule whitespace (+ (or #\space #\tab #\newline)) - (:constant nil)) +(defrule whitespace () + (postimes (|| #\space #\tab #\newline)) + nil) -(defrule alphanumeric (alphanumericp character)) +(defrule alphanumeric () + (pred #'alphanumericp character)) -(defrule string-char (or (not-doublequote character) (and #\\ #\"))) +(defrule string-char () + (|| (pred #'not-doublequote character) + (list #\\ #\"))) ;;; Here we go: an S-expression is either a list or an atom, with possibly leading whitespace. -(defrule sexp (and (? whitespace) (or magic list atom)) - (:destructure (w s &bounds start end) - (declare (ignore w)) - (list s (cons start end)))) +(defrule sexp () + (? whitespace) + (list (|| magic list atom) + (cons match-start match-end))) -(defrule magic "foobar" - (:constant :magic) - (:when (eq * :use-magic))) +(defrule magic () + (if (eq * :use-magic) + (progn "foobar" + :magic) + (fail-parse "No room for magic in this world"))) -(defrule list (and #\( sexp (* sexp) (? whitespace) #\)) - (:destructure (p1 car cdr w p2) - (declare (ignore p1 p2 w)) - (cons car cdr))) +(defrule list () + #\( + (let ((res `(,sexp ,. (times sexp)))) + (? whitespace) + #\) + res)) -(defrule atom (or string integer symbol)) +(defrule atom () + (|| string integer symbol)) -(defrule string (and #\" (* string-char) #\") - (:destructure (q1 string q2) - (declare (ignore q1 q2)) - (text string))) +(defrule string () + (text (progm #\" (times string-char) #\"))) -(defrule integer (+ (or "0" "1" "2" "3" "4" "5" "6" "7" "8" "9")) - (:lambda (list) - (parse-integer (text list) :radix 10))) +(defrule integer () + (parse-integer (text (postimes (|| "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))) + :radix 10)) -(defrule symbol (not-integer (+ alphanumeric)) - ;; NOT-INTEGER is not strictly needed because ATOM considers INTEGER before - ;; a STRING, we know can accept all sequences of alphanumerics -- we already - ;; know it isn't an integer. - (:lambda (list) - (intern (text list)))) +(defrule symbol () + (intern (text (pred #'not-integer (postimes alphanumeric))))) ;;;; Try these @@ -74,22 +79,22 @@ (let ((* :use-magic)) (parse 'sexp "foobar")) -(describe-grammar 'sexp) +;; (describe-grammar 'sexp) -(trace-rule 'sexp :recursive t) +;; (trace-rule 'sexp :recursive t) (parse 'sexp "(foo bar 1 quux)") -(untrace-rule 'sexp :recursive t) +;; (untrace-rule 'sexp :recursive t) -(defparameter *orig* (rule-expression (find-rule 'sexp))) +;; (defparameter *orig* (rule-expression (find-rule 'sexp))) -(change-rule 'sexp '(and (? whitespace) (or list symbol))) +;; (change-rule 'sexp '(and (? whitespace) (or list symbol))) (parse 'sexp "(foo bar quux)") (parse 'sexp "(foo bar 1 quux)" :junk-allowed t) -(change-rule 'sexp *orig*) +;; (change-rule 'sexp *orig*) (parse 'sexp "(foo bar 1 quux)" :junk-allowed t) From f619677c9c321934255fcaafe17f2814e3e1c113 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Mon, 18 Nov 2013 05:13:27 +0400 Subject: [PATCH 31/95] Adapt example-symbol-table.lisp to liquid --- example-symbol-table.lisp | 63 +++++++++++++++++---------------------- 1 file changed, 28 insertions(+), 35 deletions(-) diff --git a/example-symbol-table.lisp b/example-symbol-table.lisp index 6a80a7c..464d63e 100644 --- a/example-symbol-table.lisp +++ b/example-symbol-table.lisp @@ -1,12 +1,14 @@ ;;;; Esrap example: a simple grammar with scopes and symbol tables. -(require :esrap) +(require :esrap-liquid) (defpackage :symbol-table - (:use :cl :esrap)) + (:use :cl :esrap-liquid)) (in-package :symbol-table) +(enable-read-macro-tokens) + (declaim (special *symbol-table*)) (defvar *symbol-table* nil) @@ -31,49 +33,40 @@ -(defrule whitespace - (+ (or #\Space #\Tab #\Newline)) - (:constant nil)) +(defrule whitespace () + (postimes (|| #\Space #\Tab #\Newline)) + nil) -(defrule name - (+ (alphanumericp character)) - (:text t)) +(defrule name () + (text (postimes (pred #'alphanumericp character)))) -(defrule type - (+ (alphanumericp character)) - (:text t)) +(defrule type () + (times (postimes (pred #'alphanumericp character)))) -(defrule declaration - (and name #\: type) - (:destructure (name colon type) +(defrule declaration () + (destructuring-bind (name colon type) (list name #\: type) (declare (ignore colon)) (setf (lookup name) (list name :type type)) (values))) -(defrule use - name - (:lambda (name) +(defrule use () + (let ((name name)) (list :use (or (lookup name) (error "~@" name))))) - -(defrule statement - (+ (or scope declaration use)) - (:lambda (items) - (remove nil items))) - -(defrule statement/ws - (and statement (? whitespace)) - (:function first)) - -(defrule scope - (and (and #\{ (? whitespace)) - (* statement/ws) - (and #\} (? whitespace))) - (:function second) - (:around () - (let ((*symbol-table* (make-symbol-table *symbol-table*))) - (list* :scope (apply #'append (call-transform)))))) + +(defrule statement () + (remove nil (postimes (|| scope declaration use)))) + +(defrule statement/ws () + (prog1 statement (? whitespace))) + +(defrule scope () + (let ((*symbol-table* (make-symbol-table *symbol-table*))) + (list* :scope (apply #'append + (progm (progn #\{ (? whitespace)) + (* statement/ws) + (progn #\} (? whitespace))))))) (parse 'scope "{ a:int From 41f6ea9f60850db3d7cf927c27e94b1f7ac368c4 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Mon, 18 Nov 2013 05:21:05 +0400 Subject: [PATCH 32/95] Adapt example-very-context-sensitive.lisp to liquid --- example-very-context-sensitive.lisp | 58 ++++++++++++++--------------- 1 file changed, 27 insertions(+), 31 deletions(-) diff --git a/example-very-context-sensitive.lisp b/example-very-context-sensitive.lisp index c2b2888..2010685 100644 --- a/example-very-context-sensitive.lisp +++ b/example-very-context-sensitive.lisp @@ -1,57 +1,53 @@ ;;;; Esrap example: grammar, in which context is determined by a natural number -(require :esrap) +(require :esrap-liquid) (defpackage :very-context-sensitive - (:use :cl :esrap)) + (:use :cl :esrap-liquid)) (in-package :very-context-sensitive) +(enable-read-macro-tokens) + (defparameter indent 0 "Indent that is stripped from all lines.") -(defrule spaces (* #\space) - (:lambda (lst) - (length lst))) +(defrule spaces () + (length (times #\space))) (defun indented-p (len) (>= len indent)) -(defrule indented-spaces (indented-p spaces) - (:lambda (len) - (- len indent))) +(defrule indented-spaces () + (- (pred #'indented-p spaces) + indent)) -(defrule digit (character-ranges (#\0 #\9))) +(defrule digit () + (character-ranges (#\0 #\9))) -(defrule indent-spec-line (and spaces "|" (+ digit) "|" spaces #\newline) - (:destructure (wh0 ch0 digits ch1 wh1 nl0) - (declare (ignore wh0 ch0 ch1 wh1 nl0)) - (parse-integer (text digits)))) +(defrule indent-spec-line () + (parse-integer (text (progm (progn spaces "|") + (postimes digit) + (progn "|" spaces #\newline))))) -(defrule indented-line (and indented-spaces (* (not #\newline)) #\newline) - (:destructure (isps line nl0) - (declare (ignore nl0)) - (text (make-string isps :initial-element #\space) - line))) +(defrule indented-line () + (prog1 (text (make-string indented-spaces :initial-element #\space) + (times (!! #\newline))) + #\newline)) (defun more-indented-block-p (explicit-block) (>= (caddr explicit-block) indent)) -(defrule explicit-indented-block (wrap indent-spec-line - (* (or (more-indented-block-p explicit-indented-block) - (and (! indent-spec-line) - indented-line)))) - (:wrap-around (let ((indent wrapper)) - (call-parser))) - (:lambda (lst) +(defrule explicit-indented-block () + (let ((indent indent-spec-line)) `(expl-block :indent ,indent - :contents ,(mapcar (lambda (x) - (case (car x) - (expl-block x) - (t (cadr x)))) - lst)))) + :contents ,(times (|| (pred #'more-indented-block-p + explicit-indented-block) + (progn (! indent-spec-line) + indented-line)))))) -(defrule explicit-blocks (+ explicit-indented-block)) +(defrule explicit-blocks () + (postimes explicit-indented-block)) ;; (defrule implicit-indented-block (wrap "" ;; (* (and (! indent-spec-line) From ef7fdb64b5ebc8d3c1256c165d21ee52e1205bdc Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Wed, 27 Nov 2013 17:58:33 +0100 Subject: [PATCH 33/95] Fixed definition of esrap environment --- src/esrap-env.lisp | 48 ++++++++++++++++++++++++++++------------------ 1 file changed, 29 insertions(+), 19 deletions(-) diff --git a/src/esrap-env.lisp b/src/esrap-env.lisp index 612db88..e03ff88 100644 --- a/src/esrap-env.lisp +++ b/src/esrap-env.lisp @@ -11,51 +11,61 @@ (defmacro!! ,e!-define-rule (symbol args &body body) () `(,',(if symbol - (sb-int:symbolicate "DEFINE-" symbol "-RULE") + (symbolicate "DEFINE-" symbol "-RULE") 'defrule) ,symbol ,args ,@body)))) +(defun install-common-rules (hash-table) + (let ((common-rules '(any-string character string))) + (iter (for rule in common-rules) + (setf (gethash rule hash-table) + (gethash rule *rules*))))) + (defmacro define-esrap-env (symbol) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar ,(sb-int:symbolicate symbol "-RULES") (make-hash-table)) - (defvar ,(sb-int:symbolicate symbol "-CONTEXTS") nil)) - (defmacro ,(sb-int:symbolicate "WITH-" symbol "-RULES") (&body body) - `(let ((esrap-liquid::*rules* ,',(sb-int:symbolicate symbol "-RULES"))) + (defvar ,(symbolicate symbol "-RULES") (make-hash-table)) + (install-common-rules ,(symbolicate symbol "-RULES")) + (defvar ,(symbolicate symbol "-CONTEXTS") nil)) + (defmacro ,(symbolicate "WITH-" symbol "-RULES") (&body body) + `(let ((esrap-liquid::*rules* ,',(symbolicate symbol "-RULES"))) ,@body)) - (defmacro ,(sb-int:symbolicate "WITH-" symbol "-CONTEXTS") (&body body) - `(let ((esrap-liquid::contexts ,',(sb-int:symbolicate symbol "-CONTEXTS"))) + (defmacro ,(symbolicate "WITH-" symbol "-CONTEXTS") (&body body) + `(let ((esrap-liquid::contexts ,',(symbolicate symbol "-CONTEXTS"))) ,@body)) - (defmacro!! ,(sb-int:symbolicate "DEFINE-" symbol "-RULE") (symbol args &body body) + (defmacro!! ,(symbolicate "DEFINE-" symbol "-RULE") (symbol args &body body) () - `(,',(sb-int:symbolicate "WITH-" symbol "-RULES") - (,',(sb-int:symbolicate "WITH-" symbol "-CONTEXTS") + `(,',(symbolicate "WITH-" symbol "-RULES") + (,',(symbolicate "WITH-" symbol "-CONTEXTS") (defrule ,symbol ,args ,@body)))) - (defmacro ,(sb-int:symbolicate "REGISTER-" symbol "-CONTEXT") + (defmacro ,(symbolicate "REGISTER-" symbol "-CONTEXT") (context-var &rest plausible-contexts) `(progn (defparameter ,context-var ,(sb-int:keywordicate (format nil "~a" (car plausible-contexts)))) ,@(mapcar (lambda (context-name) - (let ((pred-name (sb-int:symbolicate context-name + (let ((pred-name (symbolicate context-name "-" context-var "-P")) - (rule-name (sb-int:symbolicate context-name + (rule-name (symbolicate context-name "-" context-var))) `(progn (defun ,pred-name (x) (declare (ignore x)) (equal ,context-var ,(sb-int:keywordicate context-name))) - (,(sb-int:symbolicate 'define-rule) ,rule-name (,pred-name "") - (:constant nil))))) + (,',(symbolicate "DEFINE-" symbol "-RULE") ,rule-name () + ;; KLUDGE: probably, special reader syntax for defining rules + ;; will not work here anyway + (pred #',pred-name t) + nil)))) (mapcar (lambda (x) (format nil "~a" x)) plausible-contexts)) - (push ',context-var ,',(sb-int:symbolicate symbol "-CONTEXTS")))) - (defmacro!! ,(sb-int:symbolicate symbol "-PARSE") + (push ',context-var ,',(symbolicate symbol "-CONTEXTS")))) + (defmacro!! ,(symbolicate symbol "-PARSE") (expression text &key (start nil start-p) (end nil end-p) (junk-allowed nil junk-allowed-p)) () - `(,',(sb-int:symbolicate "WITH-" symbol "-RULES") - (,',(sb-int:symbolicate "WITH-" symbol "-CONTEXTS") + `(,',(symbolicate "WITH-" symbol "-RULES") + (,',(symbolicate "WITH-" symbol "-CONTEXTS") (parse ,(if (and (consp expression) (eql (car expression) 'quote) (equal (length expression) 2) From 0d670f01156519522515cc32ec0d56e248023658 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Thu, 28 Nov 2013 00:47:44 +0100 Subject: [PATCH 34/95] Add support for testing of EOF and export FAIL-PARSE --- src/macro.lisp | 10 +++++++--- src/package.lisp | 3 +-- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/src/macro.lisp b/src/macro.lisp index 52cf0b4..c3d5f56 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -158,9 +158,13 @@ ,subexpr))) (defmacro -> (subexpr) - `(progn (let ((position position)) - ,subexpr) - (make-result nil))) + (if (and (symbolp subexpr) (equal (string subexpr) "EOF")) + `(if (equal end position) + (make-result nil) + (fail-parse "not at end-of-file")) + `(progn (let ((position position)) + ,subexpr) + (make-result nil)))) (defmacro! <- (subexpr) (if (and (symbolp subexpr) (equal (string subexpr) "SOF")) diff --git a/src/package.lisp b/src/package.lisp index 49765b5..5b85523 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -17,7 +17,6 @@ #:register-context #:concat #:defrule #:descend-with-rule #:any-string #:character #:string #:|| - #:parse - #:text + #:parse #:text #:fail-parse #:define-esrap-env #:in-esrap-env )) From 8434fb0b39b62109877899ad24c11ef522e431bc Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Thu, 28 Nov 2013 18:39:47 +0100 Subject: [PATCH 35/95] Fix ability to define rules as closures --- src/esrap.lisp | 6 +++--- src/macro.lisp | 24 ++++++++++++------------ tests/rules.lisp | 5 +++++ tests/tests.lisp | 6 ++++++ 4 files changed, 26 insertions(+), 15 deletions(-) diff --git a/src/esrap.lisp b/src/esrap.lisp index ed900d6..6d532f6 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -14,9 +14,9 @@ are allowed only if JUNK-ALLOWED is true." (unwind-protect (progn (setf (gethash g!-tmp-rule *rules*) (funcall (compile nil `(lambda () ,(with-esrap-variable-transformer - (make-rule-lambda 'esrap-tmp-rule () - (list expression) - :null)))))) + (macroexpand-all-transforming-undefs + (make-rule-lambda 'esrap-tmp-rule () + (list expression)))))))) ;; (format t "rule hash: ~a" (hash->assoc *rules*)) (let ((end (or end (length text))) (position start) diff --git a/src/macro.lisp b/src/macro.lisp index c3d5f56..d13be6c 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -34,24 +34,24 @@ `(descend-with-rule ',sym))))) ,@body)) -(defun! make-rule-lambda (name args body &optional (env :current)) - (macroexpand-all-transforming-undefs - `(named-lambda ,(intern (strcat "ESRAP-" name)) (text position end ,@args) - (let ((,g!-position position)) - (declare (ignorable ,g!-position)) - (symbol-macrolet ((match-start ,g!-position) - (match-end position)) - (with-cached-result (,name position text ,@args) - (values (progn ,@body) - position))))) - :o!-env env)) +(defun! make-rule-lambda (name args body) + `(named-lambda ,(intern (strcat "ESRAP-" name)) (text position end ,@args) + (let ((,g!-position position)) + (declare (ignorable ,g!-position)) + (symbol-macrolet ((match-start ,g!-position) + (match-end position)) + (with-cached-result (,name position text ,@args) + (values (progn ,@body) + position)))))) + (defmacro!! defrule (name args &body body) (with-esrap-reader-context (call-next-method)) (with-esrap-variable-transformer `(setf (gethash ',name *rules*) - ,(make-rule-lambda name args body)))) + ,(macroexpand-cc-all-transforming-undefs + (make-rule-lambda name args body))))) (defmacro! make-result (result &optional (length 0)) ;; We must preserve the semantics, that computation of results occurs before increment of position diff --git a/tests/rules.lisp b/tests/rules.lisp index 71a0566..7ef534a 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -226,3 +226,8 @@ (define-bar-rule abracadabra () (literal-string "bar")) + +(let ((map '((#\a . :a) (#\b . :b) (#\c . :c)))) + (defrule closure-rule () + (cdr (assoc (character-ranges (#\a #\c)) + map)))) diff --git a/tests/tests.lisp b/tests/tests.lisp index f818b0b..468405e 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -176,3 +176,9 @@ (is (equal "bar" (bar-parse 'abracadabra ""))) (signals (esrap-liquid::simple-error) (parse 'abracadabra ""))) + +(test rule-closures + (is (equal :a (parse 'closure-rule "a"))) + (is (equal :b (parse 'closure-rule "b"))) + (is (equal :c (parse 'closure-rule "c")))) + From f866ff19911a65795da8c847b9948c25be94d11c Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Sat, 30 Nov 2013 22:29:17 +0100 Subject: [PATCH 36/95] Fix a bug with advancement of position in ? macro --- src/macro.lisp | 5 ++--- tests/tests.lisp | 6 ++++++ 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/src/macro.lisp b/src/macro.lisp index d13be6c..a0bfeac 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -146,9 +146,8 @@ (block ,g!-? (let ((position position)) (handler-case ,subexpr - (simple-esrap-error () nil) - (:no-error (result) (return-from ,g!-? (make-result result)))) - (make-result nil))) + (simple-esrap-error () (values nil nil)) + (:no-error (result) (return-from ,g!-? (make-result result)))))) (when ,g!-position (setf position ,g!-position)) ,g!-result)) diff --git a/tests/tests.lisp b/tests/tests.lisp index 468405e..f6e6d9e 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -118,6 +118,12 @@ (0 . (2 . 5))) . "baz") (parse 'around.2 "{{baz}}")))) +(test optional-test + (is (equal '(#\b 2) (multiple-value-list (parse '(? (progn #\a #\b)) "ab")))) + (is (equal '(nil 0) (multiple-value-list (parse '(? (progn #\a #\b)) "ac" :junk-allowed t)))) + (is (equal '(nil 0) (multiple-value-list (parse '(? (progn #\a #\b #\c)) "abd" :junk-allowed t))))) + + (test character-range-test (is (equal '(#\a #\b) (parse '(times (character-ranges (#\a #\z) #\-)) "ab" :junk-allowed t))) (is (equal '(#\a #\b) (parse '(times (character-ranges (#\a #\z) #\-)) "ab1" :junk-allowed t))) From 148f266e09f93d2843567cc908c2c666005a1338 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Sat, 30 Nov 2013 23:20:15 +0100 Subject: [PATCH 37/95] Make non-consuming negation compatible with TEXT --- src/macro.lisp | 4 ++-- tests/tests.lisp | 3 +++ 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/macro.lisp b/src/macro.lisp index a0bfeac..caf68ac 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -80,14 +80,14 @@ (defmacro ! (expr) - "Succeeds, whenever parsing of EXPR fails. Does not consume." + "Succeeds, whenever parsing of EXPR fails. Does not consume, returns NIL, for compatibility with TEXT" `(progn (let ((position position)) (handler-case ,expr (simple-esrap-error () nil) (:no-error (result &optional position) (declare (ignore result position)) (fail-parse "Clause under non-consuming negation succeeded.")))) - (make-result t 0))) + (make-result nil 0))) (defmacro !! (expr) "Succeeds, whenever parsing of EXPR fails. Consumes, assumes than EXPR parses just one character." diff --git a/tests/tests.lisp b/tests/tests.lisp index f6e6d9e..6cfb8a9 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -73,6 +73,9 @@ "Encountered at")) (parse 'list-of-integers "1, "))) +(test non-consuming-negation + (is (equal "foo" (parse '(text (list (! "bar") "foo")) "foo")))) + (test condition.2 "Test signaling of `left-recursion' condition." (signals (esrap-liquid::left-recursion) From b56b59f89a4a9e5007eb24eeed9129ab57efcefa Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Sat, 25 Jan 2014 16:55:23 +0000 Subject: [PATCH 38/95] Add concept to readme --- README.md | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/README.md b/README.md index 8df1b4c..7d6a363 100644 --- a/README.md +++ b/README.md @@ -205,3 +205,33 @@ Grep tests in order to see basic usage. The feature is needed, if you want to define rules not in global *RULES* variable (the default), but instead in local 'environment' variable. This way you may have several non-colliding sets of rules defined at the same time. + + +Capturing-variables +------------------- + +Analogous to capturing groups in regexps, it is possible to capture +results of parsing of named rules, to ease destructuring. + +Example: instead to clumsy + +```lisp +(define-rule dressed-rule-clumsy () + (prog1 (progn "foo" "bar" "baz" + meat) + "rest1" "rest2" "rest3")) +``` + +you may write something like + +```lisp +(define-rule dressed-rule-elegant () + "foo" "bar" "baz" c!-1-meat "rest1" "rest2" "rest3" + c!-1) +``` + +I.e. result of parsing of rule with name MEAT is stored in variable C!-1, +which is later accessed. + +See tests for examples of usage. +Also see CL-MIZAR parsing.lisp, where this is used extensively. From 4d9b934277afcfdb1ac9109cbc313ccd0311a661 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Sat, 25 Jan 2014 18:40:36 +0000 Subject: [PATCH 39/95] First cut on capturing --- esrap-liquid.asd | 3 ++- src/macro.lisp | 42 ++++++++++++++++++++++++++++++++++-------- tests/rules.lisp | 4 ++++ tests/tests.lisp | 4 ++++ 4 files changed, 44 insertions(+), 9 deletions(-) diff --git a/esrap-liquid.asd b/esrap-liquid.asd index b016028..5b1b858 100644 --- a/esrap-liquid.asd +++ b/esrap-liquid.asd @@ -14,7 +14,8 @@ :version "1.1" ; odd minor version numbers are for unstable versions :description "A Packrat / Parsing Grammar / TDPL parser for Common Lisp." :licence "GPL" - :depends-on (:alexandria :defmacro-enhance :iterate :rutils :cl-indeterminism :cl-read-macro-tokens) + :depends-on (:alexandria :defmacro-enhance :iterate :rutils :cl-indeterminism :cl-read-macro-tokens + #:cl-ppcre) :serial t :components ((:module "src" :pathname "src/" diff --git a/src/macro.lisp b/src/macro.lisp index caf68ac..0b4726b 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -26,13 +26,33 @@ (character-ranges (esrap-character-ranges char-reader))) ,@body))))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro-enhance::def-*!-symbol-p c) + (defun parse-c!-symbol (sym) + (cl-ppcre:register-groups-bind (second third) + ("^C!-([^-]+)(.*)" (string sym)) + (values (intern (concatenate 'string "C!-" second)) + (if (string= "" third) + nil + (subseq third 1)))))) + + (defmacro with-esrap-variable-transformer (&body body) `(let ((*variable-transformer* (lambda (sym) - ;; KLUDGE to not parse lambda-lists in defrule args - (if (equal "CHARACTER" (string sym)) - `(descend-with-rule 'character nil) - `(descend-with-rule ',sym))))) - ,@body)) + (declare (special c!-vars)) + (if (c!-symbol-p sym) + (multiple-value-bind (var-name rule-name) (parse-c!-symbol sym) + ;; (format t "Var-name is : ~a, rule-name is : ~a~%" var-name rule-name) + (if rule-name + (progn (setf (gethash var-name c!-vars) t) + `(setq ,var-name + (descend-with-rule ',(intern rule-name)))) + (fail-transform))) + ;; KLUDGE to not parse lambda-lists in defrule args + (if (equal "CHARACTER" (string sym)) + `(descend-with-rule 'character nil) + `(descend-with-rule ',sym)))))) + ,@body)) (defun! make-rule-lambda (name args body) `(named-lambda ,(intern (strcat "ESRAP-" name)) (text position end ,@args) @@ -49,9 +69,15 @@ (with-esrap-reader-context (call-next-method)) (with-esrap-variable-transformer - `(setf (gethash ',name *rules*) - ,(macroexpand-cc-all-transforming-undefs - (make-rule-lambda name args body))))) + (let ((c!-vars (make-hash-table))) + (declare (special c!-vars)) + ;; TODO: bug - C!-vars values are kept between different execution of a rule! + (let ((pre-body (macroexpand-cc-all-transforming-undefs + (make-rule-lambda name args body)))) + `(setf (gethash ',name *rules*) + (let ,(iter (for (key nil) in-hashtable c!-vars) + (collect key)) + ,pre-body)))))) (defmacro! make-result (result &optional (length 0)) ;; We must preserve the semantics, that computation of results occurs before increment of position diff --git a/tests/rules.lisp b/tests/rules.lisp index 7ef534a..09188bd 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -231,3 +231,7 @@ (defrule closure-rule () (cdr (assoc (character-ranges (#\a #\c)) map)))) + +(defrule dressed-elegantly () + "bar" "bar" "bar" c!-1-foo+ "bar" "bar" "bar" + c!-1) diff --git a/tests/tests.lisp b/tests/tests.lisp index 6cfb8a9..fe9ee0a 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -191,3 +191,7 @@ (is (equal :b (parse 'closure-rule "b"))) (is (equal :c (parse 'closure-rule "c")))) +(test variable-capturing + (is (equal '("foo") (parse 'dressed-elegantly "barbarbarfoobarbarbar"))) + (is (equal '("foo" "foo") (parse 'dressed-elegantly "barbarbarfoofoobarbarbar")))) + From c8c998c6c03b54eed73b0312cb0cc6a4e9474248 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Mon, 27 Jan 2014 16:13:41 +0000 Subject: [PATCH 40/95] More tests on C! capturing --- tests/rules.lisp | 12 ++++++++++++ tests/tests.lisp | 10 +++++++++- 2 files changed, 21 insertions(+), 1 deletion(-) diff --git a/tests/rules.lisp b/tests/rules.lisp index 09188bd..a280413 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -215,6 +215,9 @@ (defrule foo+ () (postimes "foo")) +(defrule bar+ () + (postimes "bar")) + (defrule decimal () (parse-integer (format nil (literal-string "~{~A~}") (postimes (|| "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))))) @@ -235,3 +238,12 @@ (defrule dressed-elegantly () "bar" "bar" "bar" c!-1-foo+ "bar" "bar" "bar" c!-1) + +(defrule dressed-elegantly-2 () + (|| (progn "bar" "bar" "bar" c!-1-foo+ "bar" "bar" "bar") + (progn "bar" "bar" c!-1-foo+ "bar" "bar")) + c!-1) + +(defrule cap-overwrite () + c!-1-bar+ c!-2-foo+ c!-2-bar+ + (list c!-1 c!-2)) diff --git a/tests/tests.lisp b/tests/tests.lisp index fe9ee0a..2323223 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -193,5 +193,13 @@ (test variable-capturing (is (equal '("foo") (parse 'dressed-elegantly "barbarbarfoobarbarbar"))) - (is (equal '("foo" "foo") (parse 'dressed-elegantly "barbarbarfoofoobarbarbar")))) + (is (equal '("foo" "foo") (parse 'dressed-elegantly "barbarbarfoofoobarbarbar"))) + (is (equal '("foo") (parse 'dressed-elegantly-2 "barbarbarfoobarbarbar"))) + (is (equal '("foo" "foo") (parse 'dressed-elegantly-2 "barbarbarfoofoobarbarbar"))) + (is (equal '("foo") (parse 'dressed-elegantly-2 "barbarfoobarbar"))) + (is (equal '("foo" "foo") (parse 'dressed-elegantly-2 "barbarfoofoobarbar"))) + (is (equal '(("bar" "bar") ("bar" "bar" "bar")) (parse 'cap-overwrite "barbarfoofoobarbarbar")))) + + + From e6ac87b41b5c42677148b09c2521fa51654616cb Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Tue, 18 Feb 2014 01:13:12 +0000 Subject: [PATCH 41/95] Add proper parsing of arguments of rules --- src/macro.lisp | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/src/macro.lisp b/src/macro.lisp index 0b4726b..81406b3 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -55,14 +55,25 @@ ,@body)) (defun! make-rule-lambda (name args body) - `(named-lambda ,(intern (strcat "ESRAP-" name)) (text position end ,@args) - (let ((,g!-position position)) - (declare (ignorable ,g!-position)) - (symbol-macrolet ((match-start ,g!-position) - (match-end position)) - (with-cached-result (,name position text ,@args) - (values (progn ,@body) - position)))))) + (multiple-value-bind (reqs opts rest kwds allow-other-keys auxs kwds-p) (parse-ordinary-lambda-list args) + (declare (ignore kwds)) + (if kwds-p (error "&KEY arguments are not supported")) + (if allow-other-keys (error "&ALLOW-OTHER-KEYS is not supported")) + (if auxs (error "&AUX variables are not supported, use LET")) + `(named-lambda ,(intern (strcat "ESRAP-" name)) (text position end ,@args) + (let ((,g!-position position)) + (declare (ignorable ,g!-position)) + (symbol-macrolet ((match-start ,g!-position) + (match-end position)) + (with-cached-result (,name position text ,@reqs + ,@(if rest + `(,rest) + (iter (for (opt-name opt-default opt-supplied-p) in opts) + (collect opt-name) + (if opt-supplied-p + (collect opt-supplied-p))))) + (values (progn ,@body) + position))))))) (defmacro!! defrule (name args &body body) From 361fea814469c9f0d9e726019db96ca24a666717 Mon Sep 17 00:00:00 2001 From: Alexander Popolitov Date: Tue, 25 Feb 2014 13:22:59 +0400 Subject: [PATCH 42/95] Add tests for &OPTIONAL arguments to rules --- tests/rules.lisp | 4 ++++ tests/tests.lisp | 12 ++++++++++-- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/tests/rules.lisp b/tests/rules.lisp index a280413..9f08939 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -247,3 +247,7 @@ (defrule cap-overwrite () c!-1-bar+ c!-2-foo+ c!-2-bar+ (list c!-1 c!-2)) + +(defrule f-opt-times (&optional (n 3)) + (times "f" :exactly n)) + diff --git a/tests/tests.lisp b/tests/tests.lisp index 2323223..b27afc7 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -201,5 +201,13 @@ (is (equal '(("bar" "bar") ("bar" "bar" "bar")) (parse 'cap-overwrite "barbarfoofoobarbarbar")))) - - +(test optional-rule-args + (is (equal '("f" "f" "f") (parse 'f-opt-times "fff"))) + (is (equal '("f" "f" "f" "f") (parse '(descend-with-rule 'f-opt-times 4) "ffff"))) + (signals-esrap-error ("ffff" 3 ("Didnt make it to the end of the text" + "Encountered at")) + (parse 'f-opt-times "ffff")) + (signals-esrap-error ("fff" 3 ("Greedy repetition failed" + "Encountered at")) + (parse '(descend-with-rule 'f-opt-times 4) "fff"))) + From 0e20f4cf166b69894fd0ddc02e778573fe94ddd0 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Fri, 28 Mar 2014 01:06:32 +0000 Subject: [PATCH 43/95] Adapt to new interface of CL-INDETERMINISM --- src/esrap-env.lisp | 7 +++++-- src/macro.lisp | 5 +++-- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/src/esrap-env.lisp b/src/esrap-env.lisp index e03ff88..e4701f1 100644 --- a/src/esrap-env.lisp +++ b/src/esrap-env.lisp @@ -21,6 +21,9 @@ (setf (gethash rule hash-table) (gethash rule *rules*))))) +(defun keywordicate (str) + (intern (string str) (find-package "KEYWORD"))) + (defmacro define-esrap-env (symbol) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (defvar ,(symbolicate symbol "-RULES") (make-hash-table)) @@ -39,7 +42,7 @@ (defrule ,symbol ,args ,@body)))) (defmacro ,(symbolicate "REGISTER-" symbol "-CONTEXT") (context-var &rest plausible-contexts) - `(progn (defparameter ,context-var ,(sb-int:keywordicate (format nil "~a" (car plausible-contexts)))) + `(progn (defparameter ,context-var ,(keywordicate (format nil "~a" (car plausible-contexts)))) ,@(mapcar (lambda (context-name) (let ((pred-name (symbolicate context-name "-" @@ -51,7 +54,7 @@ `(progn (defun ,pred-name (x) (declare (ignore x)) - (equal ,context-var ,(sb-int:keywordicate context-name))) + (equal ,context-var ,(keywordicate context-name))) (,',(symbolicate "DEFINE-" symbol "-RULE") ,rule-name () ;; KLUDGE: probably, special reader syntax for defining rules ;; will not work here anyway diff --git a/src/macro.lisp b/src/macro.lisp index 81406b3..80fa85a 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -76,7 +76,7 @@ position))))))) -(defmacro!! defrule (name args &body body) +(defmacro!! defrule (name args &body body &environment env) (with-esrap-reader-context (call-next-method)) (with-esrap-variable-transformer @@ -84,7 +84,8 @@ (declare (special c!-vars)) ;; TODO: bug - C!-vars values are kept between different execution of a rule! (let ((pre-body (macroexpand-cc-all-transforming-undefs - (make-rule-lambda name args body)))) + (make-rule-lambda name args body) + :env env))) `(setf (gethash ',name *rules*) (let ,(iter (for (key nil) in-hashtable c!-vars) (collect key)) From cc0dfea4ad54ca64cd846307e55e876a28c6f6f3 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sun, 12 Oct 2014 21:40:00 +0000 Subject: [PATCH 44/95] Use alexandria's make-keyword instead of home-brewed keywordicate --- src/esrap-env.lisp | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/esrap-env.lisp b/src/esrap-env.lisp index e4701f1..cc9cf96 100644 --- a/src/esrap-env.lisp +++ b/src/esrap-env.lisp @@ -21,9 +21,6 @@ (setf (gethash rule hash-table) (gethash rule *rules*))))) -(defun keywordicate (str) - (intern (string str) (find-package "KEYWORD"))) - (defmacro define-esrap-env (symbol) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (defvar ,(symbolicate symbol "-RULES") (make-hash-table)) @@ -42,7 +39,7 @@ (defrule ,symbol ,args ,@body)))) (defmacro ,(symbolicate "REGISTER-" symbol "-CONTEXT") (context-var &rest plausible-contexts) - `(progn (defparameter ,context-var ,(keywordicate (format nil "~a" (car plausible-contexts)))) + `(progn (defparameter ,context-var ,(make-keyword (format nil "~a" (car plausible-contexts)))) ,@(mapcar (lambda (context-name) (let ((pred-name (symbolicate context-name "-" @@ -54,7 +51,7 @@ `(progn (defun ,pred-name (x) (declare (ignore x)) - (equal ,context-var ,(keywordicate context-name))) + (equal ,context-var ,(make-keyword context-name))) (,',(symbolicate "DEFINE-" symbol "-RULE") ,rule-name () ;; KLUDGE: probably, special reader syntax for defining rules ;; will not work here anyway From 91ab18b7afd54721cd5c773a865a01abec564b4f Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sun, 14 Dec 2014 16:52:52 +0100 Subject: [PATCH 45/95] Fix recursive erasure of c-bang-symbols --- src/macro.lisp | 20 +++++++++++++++++--- tests/rules.lisp | 12 ++++++++++++ tests/tests.lisp | 2 ++ 3 files changed, 31 insertions(+), 3 deletions(-) diff --git a/src/macro.lisp b/src/macro.lisp index 80fa85a..c682f49 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -87,9 +87,8 @@ (make-rule-lambda name args body) :env env))) `(setf (gethash ',name *rules*) - (let ,(iter (for (key nil) in-hashtable c!-vars) - (collect key)) - ,pre-body)))))) + ,(crunch-c!-s pre-body)))))) + (defmacro! make-result (result &optional (length 0)) ;; We must preserve the semantics, that computation of results occurs before increment of position @@ -219,3 +218,18 @@ `(|| ,@(mapcar (lambda (clause) `(progn ,@clause)) clauses))) + + + +(defun crunch-c!-s (pre-body) + (declare (special c!-vars)) + ;; (format t "pre-body ~a~%" pre-body) + (destructuring-bind (labels ((name args . body)) + . body2) pre-body + (declare (ignore labels)) + `(labels ((,name ,args + (let ,(iter (for (key nil) in-hashtable c!-vars) + (collect key)) + ,@body))) + ,@body2))) + \ No newline at end of file diff --git a/tests/rules.lisp b/tests/rules.lisp index 9f08939..d4f0dcb 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -251,3 +251,15 @@ (defrule f-opt-times (&optional (n 3)) (times "f" :exactly n)) + +(defrule cipher () + (character-ranges (#\0 #\9))) + +(defrule recurcapturing () + #\( (|| (progn c!-int-cipher c!-rc-recurcapturing) + #\a) + #\) + (cons c!-int c!-rc)) + + + diff --git a/tests/tests.lisp b/tests/tests.lisp index b27afc7..387958b 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -211,3 +211,5 @@ "Encountered at")) (parse '(descend-with-rule 'f-opt-times 4) "fff"))) +(test recursive-capturing + (is (equal '(#\1 #\2 #\3 #\4 #\5 nil) (parse 'recurcapturing "(1(2(3(4(5(a))))))")))) \ No newline at end of file From 8e0824917951bb05e399c91c14b0de56bc5fd272 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Tue, 27 Jan 2015 00:56:24 +0100 Subject: [PATCH 46/95] Explicitly isolated formatting FAIL-PARSE macro --- src/basic-rules.lisp | 8 ++++---- src/conditions.lisp | 9 ++++++--- src/esrap.lisp | 3 ++- 3 files changed, 12 insertions(+), 8 deletions(-) diff --git a/src/basic-rules.lisp b/src/basic-rules.lisp index 587d3a2..ad18b35 100644 --- a/src/basic-rules.lisp +++ b/src/basic-rules.lisp @@ -23,7 +23,7 @@ (let ((it (char text position))) (if (char= it char) (make-result it 1) - (fail-parse (literal-string "Char ~a is not equal to desired char ~a") it char))) + (fail-parse-format (literal-string "Char ~a is not equal to desired char ~a") it char))) (make-result (char text position) 1)) (fail-parse (literal-string "EOF reached while trying to parse character.")))) @@ -31,9 +31,9 @@ (let ((any-string (any-string (length string)))) (if (string= any-string string) (make-result any-string) - (fail-parse (literal-string "String ~a is not equal to desired string ~a") - any-string - string)))) + (fail-parse-format (literal-string "String ~a is not equal to desired string ~a") + any-string + string)))) (defun joinl (joinee lst) (format nil (strcat "~{~a~^" joinee "~}") lst)) diff --git a/src/conditions.lisp b/src/conditions.lisp index de5409a..f17b7d5 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -74,9 +74,12 @@ the error occurred.")) :format-control format-control :format-arguments format-arguments)) -(defmacro fail-parse (&optional (reason "No particular reason.") &rest args) - `(let ((reason (apply #'format `(nil ,,reason ,,@args)))) - (simple-esrap-error text position reason "~a~%" reason))) +(defmacro fail-parse-format (&optional (reason "No particular reason.") &rest args) + `(let ((formatted-reason (apply #'format `(nil ,,reason ,,@args)))) + (simple-esrap-error text position formatted-reason ,reason ,@args))) + +(defmacro fail-parse (&optional (reason "No particular reason.")) + `(simple-esrap-error text position ,reason ,reason)) (define-condition left-recursion (esrap-error) ((nonterminal :initarg :nonterminal :initform nil :reader left-recursion-nonterminal) diff --git a/src/esrap.lisp b/src/esrap.lisp index 6d532f6..33d18c5 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -87,7 +87,8 @@ are allowed only if JUNK-ALLOWED is true." into res) (finally (return `(let ((,g!-char (descend-with-rule 'character nil))) (cond ,@res - (t (fail-parse "Character ~s does not belong to specified range" ,g!-char))))))))) + (t (fail-parse-format "Character ~s does not belong to specified range" + ,g!-char))))))))) (defvar *indentation-hint-table* nil) From 72fbcdd912d92f140553df533bf7e72b45bee3fd Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Mon, 9 Feb 2015 01:27:04 +0100 Subject: [PATCH 47/95] Start work on stream-based parsing --- esrap-liquid.asd | 3 ++- src/iterators.lisp | 21 +++++++++++++++++++++ 2 files changed, 23 insertions(+), 1 deletion(-) create mode 100644 src/iterators.lisp diff --git a/esrap-liquid.asd b/esrap-liquid.asd index 5b1b858..187cf51 100644 --- a/esrap-liquid.asd +++ b/esrap-liquid.asd @@ -28,7 +28,8 @@ (:file "macro") (:file "esrap") (:file "basic-rules") - (:file "esrap-env"))) + (:file "esrap-env") + (:file "iterators"))) (:static-file "example-sexp.lisp") (:static-file "example-symbol-table.lisp") (:static-file "README"))) diff --git a/src/iterators.lisp b/src/iterators.lisp new file mode 100644 index 0000000..c71020a --- /dev/null +++ b/src/iterators.lisp @@ -0,0 +1,21 @@ + +;;;; iterators.lisp + +;;;; This is a part of esrap-liquid TDPL for Common Lisp +;;;; Alexander Popolitov, 2013 +;;;; For licence, see COPYING + +(in-package :esrap-liquid) + +;; I want ESRAP to be able to conveniently handle TeX token stream. +;; For this I need a caching iterator, which does the following: +;; 1) next fetches item from underlying itetator, or from cache +;; 2) random access to cache is fast +;; 3) I can discard some items from cache on demand + +(defclass super-cache-iterator () + ((cached-vals))) + +(defmethod initialize-instance :after ((this super-cache-iterator) &key &allow-other-keys) + (with-slots (cached-vals) this + (setf cached-vals (make-array 1)))) \ No newline at end of file From 9c12ebe351ccc202f506ed06c0a853e18ac46160 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sat, 14 Feb 2015 20:59:57 +0100 Subject: [PATCH 48/95] First sketch of buffer we need for stream parsing --- src/iterators.lisp | 56 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) diff --git a/src/iterators.lisp b/src/iterators.lisp index c71020a..87f8baf 100644 --- a/src/iterators.lisp +++ b/src/iterators.lisp @@ -13,6 +13,62 @@ ;; 2) random access to cache is fast ;; 3) I can discard some items from cache on demand +(defparameter buffer-vector-start-length 10) + +(defclass buffer-vector () + ((vector) + (start-pointer :initform 0))) + +(defmethod initialize-instance :after ((this buffer-vector) &key &allow-other-keys) + (with-slots (vector) this + (setf vector (make-array buffer-vector-start-length :adjustable t :fill-pointer t)))) + +(defgeneric soft-shrink (obj num-elts-discarded) + (:documentation "Shrink buffer (and cache) the soft way, just moving the start pointer")) +(defgeneric hard-shrink (obj num-elts-discarded) + (:documentation "Shrink buffer (and cache) the hard way, actually reallocating the buffer and cleaning up cache")) +(defgeneric buffer-push (elt obj) + (:documentation "Place object in the end of the buffer, necessarily increasing its size")) +(defgeneric buffer-pop (obj) + (:documentation "Pop the last element of the buffer, but not before the start pointer")) + + +(defmethod soft-shrink ((obj buffer-vector) (num-elts-discarded integer)) + (with-slots (vector start-pointer) obj + (let ((fill-pointer (fill-pointer vector))) + (if (> (+ start-pointer num-elts-discarded) fill-pointer) + (error "Attempt to soft-shrink buffer more than its active length") + (incf start-pointer num-elts-discarded))))) + +(defun calc-new-buffer-length (old-buffer-vector start-pointer) + (let ((full-array-length (array-dimension old-buffer-vector 0)) + (actual-length (- (fill-pointer old-buffer-vector) start-pointer))) + (if (> actual-length (/ full-array-length 2)) + full-array-length + (1+ (floor full-array-length 2))))) + + +(defmethod hard-shrink ((obj buffer-vector) (num-elts-discarded integer)) + (with-slots (vector start-pointer) obj + (let ((new-vector (make-array (calc-new-buffer-length vector start-pointer) :adjustable t :fill-pointer t))) + (iter (for i from 0 to (- (fill-pointer vector) start-pointer 1)) + (setf (aref new-vector i) (aref vector (+ start-pointer i)))) + (setf (fill-pointer new-vector) (- (fill-pointer vector) start-pointer) + start-pointer 0 + vector new-vector)))) + +(defmethod buffer-push (elt (obj buffer-vector)) + (with-slots (vector) obj + (vector-push-extend elt vector (array-dimension vector 0)))) + +(defmethod buffer-pop ((obj buffer-vector)) + (with-slots (vector start-pointer) obj + (if (equal start-pointer (fill-pointer vector)) + (error "Attempt to pop from vector of zero (soft) length.") + (vector-pop obj)))) + + + (defclass super-cache-iterator () ((cached-vals))) From d407c061d2af21d22610ec2b658dc142553ec965 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sat, 14 Feb 2015 21:40:34 +0100 Subject: [PATCH 49/95] Add first cut on iteration over strings --- src/iterators.lisp | 65 +++++++++++++++++++++++++++++++++++++++++----- tests/package.lisp | 2 +- tests/tests.lisp | 10 ++++++- 3 files changed, 69 insertions(+), 8 deletions(-) diff --git a/src/iterators.lisp b/src/iterators.lisp index 87f8baf..10aba5a 100644 --- a/src/iterators.lisp +++ b/src/iterators.lisp @@ -68,10 +68,63 @@ (vector-pop obj)))) - -(defclass super-cache-iterator () - ((cached-vals))) - -(defmethod initialize-instance :after ((this super-cache-iterator) &key &allow-other-keys) +;;; Pythonic approach to iteration +;;; iterators - classes with NEXT-ITER method, which raises STOP-ITERATION when iterator is depleted +(define-condition stop-iteration (error) + ()) +(defgeneric next-iter (iter) + (:documentation "Main method of iteration protocol")) + +(defclass string-iter () + ((pos :initform 0 :initarg :start) + (str :initarg :string :initform ""))) + +(defun mk-string-iter (string &key (start 0)) + (make-instance 'string-iter :string string :start start)) + +(defmethod next-iter ((iter string-iter)) + (with-slots (str pos) iter + (if (equal pos (length str)) + (error 'stop-iteration) + (let ((char (char str pos))) + (incf pos) + char)))) + +(defclass cache-iterator () + ((cached-vals) + (cached-pos :initform 0) + (sub-iter :initform (error "Please, specify underlying iterator") :initarg :sub-iter))) + +(defmethod initialize-instance :after ((this cache-iterator) &key &allow-other-keys) (with-slots (cached-vals) this - (setf cached-vals (make-array 1)))) \ No newline at end of file + (setf cached-vals (make-instance 'buffer-vector)))) + +(defun mk-cache-iter (sub-iter) + (make-instance 'cache-iterator :sub-iter sub-iter)) + +(defun rewind-to-pos (cache-iterator new-pos) + (with-slots (cached-vals cached-pos) cache-iterator + (with-slots (vector start-pointer) cached-vals + (cond ((< new-pos start-pointer) + (error "New position is less than (soft) beginning of the array.")) + ((> new-pos (fill-pointer vector)) + (error "New position is greater than cache range, and than read-from-stream value")) + (t (setf cached-pos new-pos)))))) + +(defmethod next-iter ((iter cache-iterator)) + (with-slots (cached-vals cached-pos sub-iter) iter + (if (equal cached-pos (fill-pointer sub-iter)) + (let ((new-val (next-iter sub-iter))) + (buffer-push new-val cached-vals) + (incf cached-pos) + new-val) + (let ((old-val (aref cached-vals cached-pos))) + (incf cached-pos) + old-val)))) + +(defmacro-driver! (for var in-iter iter) + (let ((kwd (if generate 'generate 'for))) + `(progn (with ,g!-iter = ,iter) + (,kwd ,var next (let ((next-val (handler-case (next-iter ,g!-iter) + (stop-iteration () (terminate))))) + next-val))))) diff --git a/tests/package.lisp b/tests/package.lisp index 12f72a1..50637f7 100644 --- a/tests/package.lisp +++ b/tests/package.lisp @@ -8,7 +8,7 @@ (in-package :cl-user) (defpackage :esrap-liquid-tests - (:use :alexandria :cl :esrap-liquid :fiveam) + (:use :alexandria :cl :esrap-liquid :fiveam #:iterate) (:shadowing-import-from :esrap-liquid "!" "!!") (:export #:run-tests)) diff --git a/tests/tests.lisp b/tests/tests.lisp index 387958b..f235373 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -212,4 +212,12 @@ (parse '(descend-with-rule 'f-opt-times 4) "fff"))) (test recursive-capturing - (is (equal '(#\1 #\2 #\3 #\4 #\5 nil) (parse 'recurcapturing "(1(2(3(4(5(a))))))")))) \ No newline at end of file + (is (equal '(#\1 #\2 #\3 #\4 #\5 nil) (parse 'recurcapturing "(1(2(3(4(5(a))))))")))) + + + +;;; String iterators + +(test simple-iterators + (is (equal '(#\a #\b #\c #\d) (iter (for c in-iter (esrap-liquid::mk-string-iter "abcd")) + (collect c))))) \ No newline at end of file From 6811478e31ee0cfb652bdba1180165d4c4410b30 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sat, 14 Feb 2015 22:02:53 +0100 Subject: [PATCH 50/95] Add test for caching iterator --- src/iterators.lisp | 28 ++++++++++++++++++---------- tests/tests.lisp | 17 ++++++++++++++++- 2 files changed, 34 insertions(+), 11 deletions(-) diff --git a/src/iterators.lisp b/src/iterators.lisp index 10aba5a..0d65330 100644 --- a/src/iterators.lisp +++ b/src/iterators.lisp @@ -97,14 +97,18 @@ (defmethod initialize-instance :after ((this cache-iterator) &key &allow-other-keys) (with-slots (cached-vals) this - (setf cached-vals (make-instance 'buffer-vector)))) + (setf cached-vals (make-instance 'buffer-vector)) + (with-slots (vector) cached-vals + (setf (fill-pointer vector) 0)))) (defun mk-cache-iter (sub-iter) (make-instance 'cache-iterator :sub-iter sub-iter)) -(defun rewind-to-pos (cache-iterator new-pos) +(defun rewind (cache-iterator &optional new-pos) (with-slots (cached-vals cached-pos) cache-iterator (with-slots (vector start-pointer) cached-vals + (when (null new-pos) + (setf new-pos start-pointer)) (cond ((< new-pos start-pointer) (error "New position is less than (soft) beginning of the array.")) ((> new-pos (fill-pointer vector)) @@ -113,14 +117,18 @@ (defmethod next-iter ((iter cache-iterator)) (with-slots (cached-vals cached-pos sub-iter) iter - (if (equal cached-pos (fill-pointer sub-iter)) - (let ((new-val (next-iter sub-iter))) - (buffer-push new-val cached-vals) - (incf cached-pos) - new-val) - (let ((old-val (aref cached-vals cached-pos))) - (incf cached-pos) - old-val)))) + (with-slots (vector) cached-vals + (format t "I'm here~%") + (if (equal cached-pos (fill-pointer vector)) + (let ((new-val (next-iter sub-iter))) + (format t "I'm here 1~%") + (buffer-push new-val cached-vals) + (incf cached-pos) + new-val) + (let ((old-val (aref vector cached-pos))) + (format t "I'm here 2~%") + (incf cached-pos) + old-val))))) (defmacro-driver! (for var in-iter iter) (let ((kwd (if generate 'generate 'for))) diff --git a/tests/tests.lisp b/tests/tests.lisp index f235373..e5a54fd 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -220,4 +220,19 @@ (test simple-iterators (is (equal '(#\a #\b #\c #\d) (iter (for c in-iter (esrap-liquid::mk-string-iter "abcd")) - (collect c))))) \ No newline at end of file + (collect c)))) + (is (equal '(#\a #\b #\a #\b #\c #\d #\c #\d) + (let ((iter (esrap-liquid::mk-cache-iter (esrap-liquid::mk-string-iter "abcd"))) + lst) + (setf lst (iter (for c in-iter iter) + (for i from 0 to 1) + (collect c))) + (esrap-liquid::rewind-to-pos iter 0) + (setf lst (append lst + (iter (for c in-iter iter) + (collect c)))) + (esrap-liquid::rewind-to-pos iter 2) + (setf lst (append lst + (iter (for c in-iter iter) + (collect c)))))))) + From 8cbab9de6e57cd0d4df49c163fd7838104e83298 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sat, 14 Feb 2015 22:04:08 +0100 Subject: [PATCH 51/95] Remove debug output --- src/iterators.lisp | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/iterators.lisp b/src/iterators.lisp index 0d65330..3951dd6 100644 --- a/src/iterators.lisp +++ b/src/iterators.lisp @@ -118,15 +118,12 @@ (defmethod next-iter ((iter cache-iterator)) (with-slots (cached-vals cached-pos sub-iter) iter (with-slots (vector) cached-vals - (format t "I'm here~%") (if (equal cached-pos (fill-pointer vector)) (let ((new-val (next-iter sub-iter))) - (format t "I'm here 1~%") (buffer-push new-val cached-vals) (incf cached-pos) new-val) (let ((old-val (aref vector cached-pos))) - (format t "I'm here 2~%") (incf cached-pos) old-val))))) From 3a223d4e19df2d120a83c88e8088a8545ead9034 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sat, 14 Feb 2015 22:23:31 +0100 Subject: [PATCH 52/95] Fix naming of REWIND in tests --- esrap-liquid.asd | 3 ++- tests/tests.lisp | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/esrap-liquid.asd b/esrap-liquid.asd index 187cf51..e2a305c 100644 --- a/esrap-liquid.asd +++ b/esrap-liquid.asd @@ -23,13 +23,14 @@ :components ((:file "package") (:file "conditions") (:file "miscellany") + (:file "iterators") (:file "memoization") (:file "rule-storage") (:file "macro") (:file "esrap") (:file "basic-rules") (:file "esrap-env") - (:file "iterators"))) + )) (:static-file "example-sexp.lisp") (:static-file "example-symbol-table.lisp") (:static-file "README"))) diff --git a/tests/tests.lisp b/tests/tests.lisp index e5a54fd..fbefd32 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -227,11 +227,11 @@ (setf lst (iter (for c in-iter iter) (for i from 0 to 1) (collect c))) - (esrap-liquid::rewind-to-pos iter 0) + (esrap-liquid::rewind iter) (setf lst (append lst (iter (for c in-iter iter) (collect c)))) - (esrap-liquid::rewind-to-pos iter 2) + (esrap-liquid::rewind iter 2) (setf lst (append lst (iter (for c in-iter iter) (collect c)))))))) From 42594960d86cf0e34c0aa8b7ed237c8585ee0249 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sun, 15 Feb 2015 00:40:42 +0100 Subject: [PATCH 53/95] Add context-nonsensitive optimization --- esrap-liquid.asd | 2 +- src/basic-rules.lisp | 6 +++--- src/macro.lisp | 12 ++++++++++- src/memoization.lisp | 46 +++++++++++++++++++++++++++++++++++++++---- src/rule-storage.lisp | 6 +++++- 5 files changed, 62 insertions(+), 10 deletions(-) diff --git a/esrap-liquid.asd b/esrap-liquid.asd index e2a305c..2c5a4c2 100644 --- a/esrap-liquid.asd +++ b/esrap-liquid.asd @@ -24,8 +24,8 @@ (:file "conditions") (:file "miscellany") (:file "iterators") - (:file "memoization") (:file "rule-storage") + (:file "memoization") (:file "macro") (:file "esrap") (:file "basic-rules") diff --git a/src/basic-rules.lisp b/src/basic-rules.lisp index ad18b35..ee50de0 100644 --- a/src/basic-rules.lisp +++ b/src/basic-rules.lisp @@ -8,7 +8,7 @@ (enable-read-macro-tokens) -(defrule any-string (length) +(def-nocontext-rule any-string (length) (let ((limit (+ length position))) (if (<= limit end) (make-result (subseq text position limit) length) @@ -17,7 +17,7 @@ `(descend-with-rule 'any-string ,length)) -(defrule character (char) +(def-nocontext-rule character (char) (if (< position end) (if char (let ((it (char text position))) @@ -27,7 +27,7 @@ (make-result (char text position) 1)) (fail-parse (literal-string "EOF reached while trying to parse character.")))) -(defrule string (string) +(def-nocontext-rule string (string) (let ((any-string (any-string (length string)))) (if (string= any-string string) (make-result any-string) diff --git a/src/macro.lisp b/src/macro.lisp index c682f49..9fb9f01 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -76,7 +76,7 @@ position))))))) -(defmacro!! defrule (name args &body body &environment env) +(defmacro!! %defrule (name args &body body &environment env) (with-esrap-reader-context (call-next-method)) (with-esrap-variable-transformer @@ -89,6 +89,16 @@ `(setf (gethash ',name *rules*) ,(crunch-c!-s pre-body)))))) +(defmacro!! defrule (name args &body body) + () + `(progn (%defrule ,name ,args ,@body) + (setf (gethash ',name *rule-context-sensitivity*) t))) + +(defmacro!! def-nocontext-rule (name args &body body) + () + `(progn (%defrule ,name ,args ,@body) + (setf (gethash ',name *rule-context-sensitivity*) nil))) + (defmacro! make-result (result &optional (length 0)) ;; We must preserve the semantics, that computation of results occurs before increment of position diff --git a/src/memoization.lisp b/src/memoization.lisp index f4caa29..84f3468 100644 --- a/src/memoization.lisp +++ b/src/memoization.lisp @@ -12,14 +12,52 @@ (defvar *cache*) +(defclass esrap-cache () + ((pos-hashtable :initform (make-hash-table :test #'equal)) + (start-pos :initform 0))) + (defun make-cache () - (make-hash-table :test #'equal)) + (make-instance 'esrap-cache)) + +(defgeneric get-cached (symbol position args cache) + (:documentation "Accessor for cached parsing results.")) + +(defun ensure-subpos-hash! (pos-hash pos) + (multiple-value-bind (it got) (gethash pos pos-hash) + (if got + it + (setf (gethash pos pos-hash) (make-hash-table :test #'equal))))) -(defun get-cached (symbol position args cache) - (gethash `(,symbol ,position ,args ,@(mapcar #'symbol-value contexts)) cache)) +(defmethod get-cached (symbol position args (cache esrap-cache)) + (with-slots (pos-hashtable) cache + (let ((subpos-hash (ensure-subpos-hash! pos-hashtable position))) + (if (context-sensitive-rule-p symbol) + (gethash `(,symbol ,args ,@(mapcar #'symbol-value contexts)) subpos-hash) + (gethash `(,symbol ,args) subpos-hash))))) (defun (setf get-cached) (result symbol position args cache) - (setf (gethash `(,symbol ,position ,args ,@(mapcar #'symbol-value contexts)) cache) result)) + (with-slots (pos-hashtable) cache + (let ((subpos-hash (ensure-subpos-hash! pos-hashtable position))) + (if (context-sensitive-rule-p symbol) + (setf (gethash `(,symbol ,args ,@(mapcar #'symbol-value contexts)) subpos-hash) result) + (setf (gethash `(,symbol ,args) subpos-hash) result))))) + +(defmethod soft-shrink ((obj esrap-cache) num-elts-discarded) + (with-slots (start-pos pos-hashtable) obj + (iter (for i from start-pos to (1- num-elts-discarded)) + (remhash i pos-hashtable)) + (incf start-pos num-elts-discarded))) + +(defmethod hard-shrink ((obj esrap-cache) num-elts-discarded) + (with-slots (start-pos pos-hashtable) obj + (let ((new-hash (make-hash-table :test #'equal))) + (iter (for (key val) in-hashtable pos-hashtable) + (if (>= key (+ start-pos num-elts-discarded)) + (setf (gethash (- key (+ start-pos num-elts-discarded)) new-hash) + val))) + (setf start-pos 0 + pos-hashtable new-hash)))) + (defvar *nonterminal-stack* nil) diff --git a/src/rule-storage.lisp b/src/rule-storage.lisp index 03193ec..3215729 100644 --- a/src/rule-storage.lisp +++ b/src/rule-storage.lisp @@ -15,9 +15,13 @@ ;;; accessible via RULE-SYMBOL. (defvar *rules* (make-hash-table)) +(defvar *rule-context-sensitivity* (make-hash-table)) + +(defun context-sensitive-rule-p (symbol) + (gethash symbol *rule-context-sensitivity*)) (defun clear-rules () (clrhash *rules*) + (clrhash *rule-context-sensitivity*) nil) - From 9b985ae07a51f6d96fed7ef42ea70657279c7e49 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sun, 15 Feb 2015 17:56:12 +0100 Subject: [PATCH 54/95] Debugging streaming --- esrap-liquid.asd | 2 +- src/basic-rules.lisp | 38 ++++++++----- src/conditions.lisp | 8 +-- src/esrap.lisp | 67 ++++++++++++++--------- src/iterators.lisp | 36 +++++++++++++ src/macro.lisp | 123 ++++++++++++++++++++++--------------------- src/memoization.lisp | 16 +++--- 7 files changed, 179 insertions(+), 111 deletions(-) diff --git a/esrap-liquid.asd b/esrap-liquid.asd index 2c5a4c2..f963e36 100644 --- a/esrap-liquid.asd +++ b/esrap-liquid.asd @@ -11,7 +11,7 @@ (in-package :esrap-liquid-system) (defsystem :esrap-liquid - :version "1.1" ; odd minor version numbers are for unstable versions + :version "1.3" ; odd minor version numbers are for unstable versions :description "A Packrat / Parsing Grammar / TDPL parser for Common Lisp." :licence "GPL" :depends-on (:alexandria :defmacro-enhance :iterate :rutils :cl-indeterminism :cl-read-macro-tokens diff --git a/src/basic-rules.lisp b/src/basic-rules.lisp index ee50de0..3098ebc 100644 --- a/src/basic-rules.lisp +++ b/src/basic-rules.lisp @@ -8,24 +8,38 @@ (enable-read-macro-tokens) +(def-nocontext-rule eof () + (handler-case (next-iter the-iter) + (stop-iteration () (make-result 'eof)) + (:no-error (token) + (declare (ignore token)) + (rel-rewind the-iter) + (fail-parse (literal-string "Not at the end of token stream."))))) + +(def-nocontext-rule sof () + (if (start-of-iter-p the-iter) + (make-result 'sof) + (fail-parse (literal-string "Not at the start of token stream.")))) + (def-nocontext-rule any-string (length) - (let ((limit (+ length position))) - (if (<= limit end) - (make-result (subseq text position limit) length) - (fail-parse (literal-string "Unable to parse any string of specified length."))))) + (let ((pre-res (handler-case (iter (for i from 1 to length) + (collect (next-iter the-iter))) + (stop-iteration () + (fail-parse (literal-string "EOF while trying to parse any string of specified length.")))))) + (make-result (coerce pre-res 'string) length))) + (defmacro any-string (length) `(descend-with-rule 'any-string ,length)) (def-nocontext-rule character (char) - (if (< position end) - (if char - (let ((it (char text position))) - (if (char= it char) - (make-result it 1) - (fail-parse-format (literal-string "Char ~a is not equal to desired char ~a") it char))) - (make-result (char text position) 1)) - (fail-parse (literal-string "EOF reached while trying to parse character.")))) + (let ((it (handler-case (next-iter the-iter) + (stop-iteration () (fail-parse (literal-string "EOF reached while trying to parse character.")))))) + (if (not char) + (make-result it 1) + (if (char= it char) + (make-result it 1) + (fail-parse-format (literal-string "Char ~a is not equal to desired char ~a") it char))))) (def-nocontext-rule string (string) (let ((any-string (any-string (length string)))) diff --git a/src/conditions.lisp b/src/conditions.lisp index f17b7d5..6dc36f3 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -66,9 +66,9 @@ the error occurred.")) (declaim (ftype (function (t t t &rest t) (values nil &optional)) simple-esrap-error)) -(defun simple-esrap-error (text position reason format-control &rest format-arguments) +(defun simple-esrap-error (position reason format-control &rest format-arguments) (error 'simple-esrap-error - :text text + :text "" :position position :reason reason :format-control format-control @@ -76,10 +76,10 @@ the error occurred.")) (defmacro fail-parse-format (&optional (reason "No particular reason.") &rest args) `(let ((formatted-reason (apply #'format `(nil ,,reason ,,@args)))) - (simple-esrap-error text position formatted-reason ,reason ,@args))) + (simple-esrap-error (+ the-position the-length) formatted-reason ,reason ,@args))) (defmacro fail-parse (&optional (reason "No particular reason.")) - `(simple-esrap-error text position ,reason ,reason)) + `(simple-esrap-error (+ the-position the-length) ,reason ,reason)) (define-condition left-recursion (esrap-error) ((nonterminal :initarg :nonterminal :initform nil :reader left-recursion-nonterminal) diff --git a/src/esrap.lisp b/src/esrap.lisp index 33d18c5..84e2c2a 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -8,29 +8,42 @@ ;;; MAIN INTERFACE -(defun! parse (expression text &key (start 0) end junk-allowed) +(defmacro! with-tmp-rule ((var expression) &body body) + `(let ((,var (gensym "TMP-RULE"))) + (unwind-protect (progn (setf (gethash ,var *rules*) + (funcall (compile nil `(lambda () + ,(with-esrap-variable-transformer + (macroexpand-all-transforming-undefs + (make-rule-lambda 'esrap-tmp-rule () + (list ,expression)))))))) + ,@body) + (remhash ,var *rules*)))) + + +(defun parse-token-iter (expression token-iter &key junk-allowed) + (let ((the-iter token-iter) + (*cache* (make-cache)) + (the-position 0) + (the-length 0)) + (with-tmp-rule (tmp-rule expression) + (let ((result (handler-case (descend-with-rule tmp-rule) + (simple-esrap-error (e) + (if junk-allowed + (values nil 0) + (error e)))))) + (when (not junk-allowed) + (handler-case (descend-with-rule 'eof) + (simple-esrap-error () + (fail-parse "Didnt make it to the end of the text")))) + (values result the-length))))) + +(defun mk-esrap-iter-from-string (str start end) + (mk-cache-iter (mk-string-iter (subseq str start end)))) + +(defun parse (expression text &key (start 0) end junk-allowed) "Parses TEXT using EXPRESSION from START to END. Incomplete parses are allowed only if JUNK-ALLOWED is true." - (unwind-protect (progn (setf (gethash g!-tmp-rule *rules*) - (funcall (compile nil `(lambda () - ,(with-esrap-variable-transformer - (macroexpand-all-transforming-undefs - (make-rule-lambda 'esrap-tmp-rule () - (list expression)))))))) - ;; (format t "rule hash: ~a" (hash->assoc *rules*)) - (let ((end (or end (length text))) - (position start) - (*cache* (make-cache))) - (handler-case (let ((result (descend-with-rule g!-tmp-rule))) - (if (and (not junk-allowed) - (not (equal end position))) - (fail-parse "Didnt make it to the end of the text") - (values result position))) - (simple-esrap-error (e) - (if junk-allowed - (values nil start) - (error e)))))) - (remhash g!-tmp-rule *rules*))) + (parse-token-iter expression (mk-esrap-iter-from-string text start end) :junk-allowed junk-allowed)) ;; Read behaviour of PARSE is different from that of usual reader macros, ;; but we want to DEFMACRO!! also capture it, hence define new reader class @@ -40,12 +53,14 @@ are allowed only if JUNK-ALLOWED is true." (let ((expression (with-esrap-reader-context (read stream t nil t)))) `(,(slot-value obj 'cl-read-macro-tokens::name) ,expression ,@(read-list-old stream token)))) - (setf (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-classes*) 'parse-reader-class - (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-instances*) (make-instance 'parse-reader-class - :name 'parse)) - (setf (gethash 'parse *read-macro-tokens*) + (setf (gethash 'parse-token-iter cl-read-macro-tokens::*read-macro-tokens-classes*) + 'parse-reader-class + (gethash 'parse-token-iter cl-read-macro-tokens::*read-macro-tokens-instances*) + (make-instance 'parse-reader-class + :name 'parse-token-iter)) + (setf (gethash 'parse-token-iter *read-macro-tokens*) (lambda (stream token) - (read-handler (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-instances*) + (read-handler (gethash 'parse-token-iter cl-read-macro-tokens::*read-macro-tokens-instances*) stream token)))) diff --git a/src/iterators.lisp b/src/iterators.lisp index 3951dd6..b6a2168 100644 --- a/src/iterators.lisp +++ b/src/iterators.lisp @@ -114,6 +114,17 @@ ((> new-pos (fill-pointer vector)) (error "New position is greater than cache range, and than read-from-stream value")) (t (setf cached-pos new-pos)))))) + +(defun rel-rewind (cache-iterator &optional (delta 1)) + "Relative rewind" + (with-slots (cached-vals cached-pos) cache-iterator + (with-slots (vector start-pointer) cached-vals + (cond ((< (- cached-pos delta) start-pointer) + (error "New position is less than (soft) beginning of the array.")) + ((> (- cached-pos delta) (fill-pointer vector)) + (error "New position is greater than cache range, and than read-from-stream value")) + (t (setf cached-pos (- cached-pos delta))))))) + (defmethod next-iter ((iter cache-iterator)) (with-slots (cached-vals cached-pos sub-iter) iter @@ -133,3 +144,28 @@ (,kwd ,var next (let ((next-val (handler-case (next-iter ,g!-iter) (stop-iteration () (terminate))))) next-val))))) + +(defgeneric start-of-iter-p (iter) + (:documentation "T if the given iter is at the start. True by default.")) +(defmethod start-of-iter-p ((iter t)) + t) + +(defmethod start-of-iter-p ((iter cache-iterator)) + (with-slots (cached-pos cached-vals) iter + (with-slots (start-pos) cached-vals + (equal start-pos cached-pos)))) + +(defparameter the-iter nil) +(defparameter the-length 0) +(defparameter the-position 0) + +(defmacro! with-saved-iter-state ((iter) &body body) + `(let ((,g!-cached-pos (slot-value ,iter 'cached-pos))) + (flet ((restore-iter-state () + (rewind ,iter ,g!-cached-pos))) + ,@body))) + +(defun print-iter-state (cached-iter) + (with-slots (cached-vals cached-pos) cached-iter + (with-slots (start-pointer vector) cached-vals + (format t "Pos is: ~a, Start is: ~a, Cache contents is ~a~%" cached-pos start-pointer vector)))) \ No newline at end of file diff --git a/src/macro.lisp b/src/macro.lisp index 9fb9f01..53ce1b8 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -8,12 +8,10 @@ (defmacro! descend-with-rule (o!-sym &rest args) `(multiple-value-bind (,g!-it ,g!-got) (gethash ,o!-sym *rules*) - ;; (format t "sym: ~a ~a~%" ,o!-sym position) (if (not ,g!-got) (error "Undefined rule: ~s" ,o!-sym) - (multiple-value-bind (result new-position) (funcall ,g!-it text position end ,@args) - ;; (format t "position before setting ~a, after setting would be ~a" position new-position) - (setf position new-position) + (multiple-value-bind (result new-length) (funcall ,g!-it ,@args) + (incf the-length new-length) result)))) (defmacro with-esrap-reader-context (&body body) @@ -60,20 +58,18 @@ (if kwds-p (error "&KEY arguments are not supported")) (if allow-other-keys (error "&ALLOW-OTHER-KEYS is not supported")) (if auxs (error "&AUX variables are not supported, use LET")) - `(named-lambda ,(intern (strcat "ESRAP-" name)) (text position end ,@args) - (let ((,g!-position position)) - (declare (ignorable ,g!-position)) - (symbol-macrolet ((match-start ,g!-position) - (match-end position)) - (with-cached-result (,name position text ,@reqs - ,@(if rest - `(,rest) - (iter (for (opt-name opt-default opt-supplied-p) in opts) - (collect opt-name) - (if opt-supplied-p - (collect opt-supplied-p))))) - (values (progn ,@body) - position))))))) + `(named-lambda ,(intern (strcat "ESRAP-" name)) (,@args) + (with-cached-result (,name ,@reqs + ,@(if rest + `(,rest) + (iter (for (opt-name opt-default opt-supplied-p) in opts) + (collect opt-name) + (if opt-supplied-p + (collect opt-supplied-p))))) + (let* ((the-position (+ the-position the-length)) + (the-length 0)) + (values (progn ,@body) + the-length)))))) (defmacro!! %defrule (name args &body body &environment env) @@ -82,6 +78,7 @@ (with-esrap-variable-transformer (let ((c!-vars (make-hash-table))) (declare (special c!-vars)) + (format t "I'm starting to actually expand!~%") ;; TODO: bug - C!-vars values are kept between different execution of a rule! (let ((pre-body (macroexpand-cc-all-transforming-undefs (make-rule-lambda name args body) @@ -101,67 +98,79 @@ (defmacro! make-result (result &optional (length 0)) - ;; We must preserve the semantics, that computation of results occurs before increment of position + ;; We must preserve the semantics, that computation of results occurs before increment of length `(let ((,g!-result ,result)) - (incf position ,length) - (values ,g!-result position))) + (values ,g!-result (incf the-length ,length)))) (defmacro! || (&rest clauses) - `(multiple-value-bind (,g!-result ,g!-position) - ;; All this tricky business with BLOCK just for automatic POSITION tracking. + `(multiple-value-bind (,g!-result ,g!-the-length) + ;; All this tricky business with BLOCK just for automatic LENGTH tracking. (block ,g!-ordered-choice (let (,g!-parse-errors) ,@(mapcar (lambda (clause) - `(handler-case (let ((position position)) - ;; (format t "Im in ordered choice~%") - (return-from ,g!-ordered-choice (values ,clause position))) - (simple-esrap-error (e) (push e ,g!-parse-errors)))) + `(let ((the-length 0)) + (print-iter-state the-iter) + (with-saved-iter-state (the-iter) + (handler-case (return-from ,g!-ordered-choice (values ,clause the-length)) + (simple-esrap-error (e) + (restore-iter-state) + (push e ,g!-parse-errors)))))) clauses) (fail-parse (joinl "~%" (mapcar (lambda (x) (slot-value x 'reason)) (nreverse ,g!-parse-errors)))))) - (setf position ,g!-position) + (incf the-length ,g!-the-length) ,g!-result)) (defmacro ! (expr) "Succeeds, whenever parsing of EXPR fails. Does not consume, returns NIL, for compatibility with TEXT" - `(progn (let ((position position)) + `(progn (let ((the-length 0)) (handler-case ,expr (simple-esrap-error () nil) - (:no-error (result &optional position) - (declare (ignore result position)) + (:no-error (result &optional the-length) + (declare (ignore result the-length)) (fail-parse "Clause under non-consuming negation succeeded.")))) (make-result nil 0))) (defmacro !! (expr) "Succeeds, whenever parsing of EXPR fails. Consumes, assumes than EXPR parses just one character." - `(progn (let ((position position)) + `(progn (let ((the-length 0)) (handler-case ,expr (simple-esrap-error () nil) - (:no-error (result &optional position) - (declare (ignore result position)) + (:no-error (result &optional the-length) + (declare (ignore result the-length)) (fail-parse "Clause under consuming negation succeeded.")))) - (if (equal end position) - (fail-parse "Reached EOF while trying to consume character.") - (make-result (char text position) 1)))) + ;; TODO : here was a check about EOF. How should I properly address this with streams? + (make-result 'caboom! 1))) + (defmacro! times (subexpr &key from upto exactly) (flet ((frob (condition) `(let (,g!-result) (iter ,(if (or upto exactly) `(for ,g!-i from 1 to ,(or upto exactly))) - (multiple-value-bind (,g!-subresult ,g!-position) - (handler-case (let ((position position)) - (values ,subexpr position)) - (simple-esrap-error () (finish))) + (format t "Next TIMES: ") + (print-iter-state the-iter) + (multiple-value-bind (,g!-subresult ,g!-the-length) + (with-saved-iter-state (the-iter) + (format t " Inside subexpression:~%") + (handler-case (let ((the-length 0)) + (let ((subexpr ,subexpr)) + (format t " succeeding ~s ~a~%" subexpr the-length) + (print-iter-state the-iter) + (values subexpr the-length))) + (simple-esrap-error () + (format t " failing~%") + (restore-iter-state) + (finish)))) (if-first-time nil - (if (equal ,g!-position position) + (if (equal ,g!-the-length 0) (terminate))) (push ,g!-subresult ,g!-result) - (setf position ,g!-position)) + (incf the-length ,g!-the-length)) (finally (if ,condition (return (make-result (nreverse ,g!-result))) (fail-parse "Greedy repetition failed."))))))) @@ -189,40 +198,36 @@ `(progn ,start (prog1 ,meat ,end))) (defmacro! ? (subexpr) - `(multiple-value-bind (,g!-result ,g!-position) + `(multiple-value-bind (,g!-result ,g!-the-length) (block ,g!-? - (let ((position position)) + (let ((the-length 0)) (handler-case ,subexpr (simple-esrap-error () (values nil nil)) (:no-error (result) (return-from ,g!-? (make-result result)))))) - (when ,g!-position - (setf position ,g!-position)) + (when ,g!-the-length + (incf the-length ,g!-the-length)) ,g!-result)) (defmacro & (subexpr) - `(make-result (let ((position position)) + `(make-result (let ((the-length 0)) ,subexpr))) (defmacro -> (subexpr) (if (and (symbolp subexpr) (equal (string subexpr) "EOF")) - `(if (equal end position) - (make-result nil) - (fail-parse "not at end-of-file")) - `(progn (let ((position position)) + `(descend-with-rule 'eof) + `(progn (let ((the-length 0)) ,subexpr) (make-result nil)))) (defmacro! <- (subexpr) (if (and (symbolp subexpr) (equal (string subexpr) "SOF")) - `(if (equal 0 position) - (make-result nil) - (fail-parse "not at start-of-file")) - `(let ((,g!-old-position position) - (position (1- position))) + `(descend-with-rule 'sof) + `(let ((the-length 0)) + (rel-rewind the-iter) (let ((,g!-result ,subexpr)) - (if (equal ,g!-old-position position) + (if (equal the-length 1) (make-result nil) - (fail-parse "Parsing of subexpr took more than 1 char.")))))) + (fail-parse "Parsing of subexpr took more than 1 token.")))))) (defmacro! cond-parse (&rest clauses) `(|| ,@(mapcar (lambda (clause) diff --git a/src/memoization.lisp b/src/memoization.lisp index 84f3468..4785061 100644 --- a/src/memoization.lisp +++ b/src/memoization.lisp @@ -68,18 +68,16 @@ (defun failed-parse-p (e) (typep e 'simple-esrap-error)) -;;; SYMBOL, POSITION, and CACHE must all be lexical variables! -(defmacro! with-cached-result ((symbol position text &rest args) &body forms) +(defmacro! with-cached-result ((symbol &rest args) &body forms) `(let* ((,g!-cache *cache*) (,g!-args (list ,@args)) - (,g!-position ,position) + (,g!-position (+ the-position the-length)) (,g!-result (get-cached ',symbol ,g!-position ,g!-args ,g!-cache)) (*nonterminal-stack* (cons ',symbol *nonterminal-stack*))) ;; (format t "hashassoc ~a~%" (hash->assoc ,g!-cache)) ;; (format t "sym: ~a pos: ~a res: ~a~%" ',symbol ,g!-position ,g!-result) (cond ((eq :left-recursion ,g!-result) (error 'left-recursion - :text ,text :position ,g!-position :nonterminal ',symbol :path (reverse *nonterminal-stack*))) @@ -91,14 +89,14 @@ ;; then compute the result and cache that. (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) :left-recursion) ;; (format t "hashassoc 2 ~a~%" (hash->assoc ,g!-cache)) - (multiple-value-bind (result position) (handler-case (locally ,@forms) + (multiple-value-bind (result length) (handler-case (locally ,@forms) (simple-esrap-error (e) e)) - ;; POSITION is non-NIL only for successful parses - (if position + ;; LENGTH is non-NIL only for successful parses + (if length (progn (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) - (cons result position)) + (cons result length)) ;; (format t "hashassoc 2.5 ~a~%" (hash->assoc ,g!-cache)) - (values result position)) + (values result length)) (progn (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) result) ;; (format t "hashassoc 3 ~a~%" (hash->assoc ,g!-cache)) From 2a7ad391856ea24268af264e778f48969784f200 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sun, 15 Feb 2015 21:38:43 +0100 Subject: [PATCH 55/95] Fix bug with TIMES --- src/iterators.lisp | 3 ++- src/macro.lisp | 22 ++++++++++++---------- src/memoization.lisp | 4 +++- 3 files changed, 17 insertions(+), 12 deletions(-) diff --git a/src/iterators.lisp b/src/iterators.lisp index b6a2168..2b43cc8 100644 --- a/src/iterators.lisp +++ b/src/iterators.lisp @@ -168,4 +168,5 @@ (defun print-iter-state (cached-iter) (with-slots (cached-vals cached-pos) cached-iter (with-slots (start-pointer vector) cached-vals - (format t "Pos is: ~a, Start is: ~a, Cache contents is ~a~%" cached-pos start-pointer vector)))) \ No newline at end of file + (format t "Pos is: ~a, Start is: ~a, Cache contents is ~a, the-pos is: ~a, the-length is: ~a~%" + cached-pos start-pointer vector the-position the-length)))) \ No newline at end of file diff --git a/src/macro.lisp b/src/macro.lisp index 53ce1b8..b84c8a1 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -59,15 +59,15 @@ (if allow-other-keys (error "&ALLOW-OTHER-KEYS is not supported")) (if auxs (error "&AUX variables are not supported, use LET")) `(named-lambda ,(intern (strcat "ESRAP-" name)) (,@args) - (with-cached-result (,name ,@reqs - ,@(if rest - `(,rest) - (iter (for (opt-name opt-default opt-supplied-p) in opts) - (collect opt-name) - (if opt-supplied-p - (collect opt-supplied-p))))) - (let* ((the-position (+ the-position the-length)) - (the-length 0)) + (let* ((the-position (+ the-position the-length)) + (the-length 0)) + (with-cached-result (,name ,@reqs + ,@(if rest + `(,rest) + (iter (for (opt-name opt-default opt-supplied-p) in opts) + (collect opt-name) + (if opt-supplied-p + (collect opt-supplied-p))))) (values (progn ,@body) the-length)))))) @@ -121,6 +121,7 @@ (mapcar (lambda (x) (slot-value x 'reason)) (nreverse ,g!-parse-errors)))))) + (format t "After ||: ~%") (print-iter-state the-iter) (incf the-length ,g!-the-length) ,g!-result)) @@ -157,7 +158,8 @@ (multiple-value-bind (,g!-subresult ,g!-the-length) (with-saved-iter-state (the-iter) (format t " Inside subexpression:~%") - (handler-case (let ((the-length 0)) + (handler-case (let* ((the-position (+ the-position the-length)) + (the-length 0)) (let ((subexpr ,subexpr)) (format t " succeeding ~s ~a~%" subexpr the-length) (print-iter-state the-iter) diff --git a/src/memoization.lisp b/src/memoization.lisp index 4785061..394c1f2 100644 --- a/src/memoization.lisp +++ b/src/memoization.lisp @@ -81,10 +81,12 @@ :position ,g!-position :nonterminal ',symbol :path (reverse *nonterminal-stack*))) - (,g!-result (if (failed-parse-p ,g!-result) + (,g!-result (format t "Using result from cache: ~a ~a ~a~%" ',symbol ,g!-position ,g!-result) + (if (failed-parse-p ,g!-result) (error ,g!-result) (values (car ,g!-result) (cdr ,g!-result)))) (t + (format t "Calculating result anew: ~a ~a ~a~%" ',symbol ,g!-position ,g!-result) ;; First mark this pair with :LEFT-RECURSION to detect left-recursion, ;; then compute the result and cache that. (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) :left-recursion) From 3b4391d0b400aa2d6dc831d9adc5d534afa0a59e Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Mon, 16 Feb 2015 00:32:46 +0100 Subject: [PATCH 56/95] Make basic tests work --- src/basic-rules.lisp | 11 +++++- src/conditions.lisp | 80 +++++++++++++++++++++---------------------- src/iterators.lisp | 21 ++++++++---- src/macro.lisp | 81 ++++++++++++++++++++++++++++---------------- src/memoization.lisp | 5 +-- tests/rules.lisp | 6 +++- tests/tests.lisp | 3 ++ 7 files changed, 126 insertions(+), 81 deletions(-) diff --git a/src/basic-rules.lisp b/src/basic-rules.lisp index 3098ebc..322b4a9 100644 --- a/src/basic-rules.lisp +++ b/src/basic-rules.lisp @@ -31,14 +31,23 @@ (defmacro any-string (length) `(descend-with-rule 'any-string ,length)) +(def-nocontext-rule any-token () + (make-result (handler-case (next-iter the-iter) + (stop-iteration () + (fail-parse (literal-string "EOF reached while trying to parse any token.")))) + 1)) + (def-nocontext-rule character (char) (let ((it (handler-case (next-iter the-iter) (stop-iteration () (fail-parse (literal-string "EOF reached while trying to parse character.")))))) + (format t (literal-string " in character: ~s ~s~%") it char) + (print-iter-state the-iter) (if (not char) (make-result it 1) (if (char= it char) - (make-result it 1) + (progn (format t (literal-string " succeeding in character!~%")) + (make-result it 1)) (fail-parse-format (literal-string "Char ~a is not equal to desired char ~a") it char))))) (def-nocontext-rule string (string) diff --git a/src/conditions.lisp b/src/conditions.lisp index 6dc36f3..ac32f6d 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -16,46 +16,46 @@ string that was being parsed, and ESRAP-ERROR-POSITION the position at which the error occurred.")) -(defmethod print-object ((condition esrap-error) stream) - (if *print-escape* - (call-next-method) - ;; FIXME: this looks like it won't do the right thing when used as part of a - ;; logical block. - (when (or (not *print-lines*) (> *print-lines* 1)) - (if-let ((text (esrap-error-text condition)) - (position (esrap-error-position condition))) - (let* ((line (count #\Newline text :end position)) - (column (- position (or (position #\Newline text - :end position - :from-end t) - 0) - 1)) - ;; FIXME: magic numbers - (start (or (position #\Newline text - :start (max 0 (- position 32)) - :end (max 0 (- position 24)) - :from-end t) - (max 0 (- position 24)))) - (end (min (length text) (+ position 24))) - (newline (or (position #\Newline text - :start start - :end position - :from-end t) - start)) - (*print-circle* nil)) - (format stream "~2&~A~2& Encountered at:~% ~ - ~A~% ~ - ~V@T^ (Line ~D, Column ~D, Position ~D)~%" - (if-let ((reason (esrap-error-reason condition))) - reason - "No particular reason") - (if (emptyp text) - "" - (subseq text start end)) - (- position newline) - (1+ line) (1+ column) - position)) - (format stream "~2& "))))) +;; (defmethod print-object ((condition esrap-error) stream) +;; (if *print-escape* +;; (call-next-method) +;; ;; FIXME: this looks like it won't do the right thing when used as part of a +;; ;; logical block. +;; (when (or (not *print-lines*) (> *print-lines* 1)) +;; (if-let ((text (esrap-error-text condition)) +;; (position (esrap-error-position condition))) +;; (let* ((line (count #\Newline text :end position)) +;; (column (- position (or (position #\Newline text +;; :end position +;; :from-end t) +;; 0) +;; 1)) +;; ;; FIXME: magic numbers +;; (start (or (position #\Newline text +;; :start (max 0 (- position 32)) +;; :end (max 0 (- position 24)) +;; :from-end t) +;; (max 0 (- position 24)))) +;; (end (min (length text) (+ position 24))) +;; (newline (or (position #\Newline text +;; :start start +;; :end position +;; :from-end t) +;; start)) +;; (*print-circle* nil)) +;; (format stream "~2&~A~2& Encountered at:~% ~ +;; ~A~% ~ +;; ~V@T^ (Line ~D, Column ~D, Position ~D)~%" +;; (if-let ((reason (esrap-error-reason condition))) +;; reason +;; "No particular reason") +;; (if (emptyp text) +;; "" +;; (subseq text start end)) +;; (- position newline) +;; (1+ line) (1+ column) +;; position)) +;; (format stream "~2& "))))) (define-condition simple-esrap-error (esrap-error simple-condition) ()) diff --git a/src/iterators.lisp b/src/iterators.lisp index 2b43cc8..7c2309e 100644 --- a/src/iterators.lisp +++ b/src/iterators.lisp @@ -33,11 +33,18 @@ (:documentation "Pop the last element of the buffer, but not before the start pointer")) +(define-condition buffer-error (error) + ((msg :initarg :msg :initform nil))) + +(defun buffer-error (str) + (error 'buffer-error :msg str)) + + (defmethod soft-shrink ((obj buffer-vector) (num-elts-discarded integer)) (with-slots (vector start-pointer) obj (let ((fill-pointer (fill-pointer vector))) (if (> (+ start-pointer num-elts-discarded) fill-pointer) - (error "Attempt to soft-shrink buffer more than its active length") + (buffer-error "Attempt to soft-shrink buffer more than its active length") (incf start-pointer num-elts-discarded))))) (defun calc-new-buffer-length (old-buffer-vector start-pointer) @@ -64,7 +71,7 @@ (defmethod buffer-pop ((obj buffer-vector)) (with-slots (vector start-pointer) obj (if (equal start-pointer (fill-pointer vector)) - (error "Attempt to pop from vector of zero (soft) length.") + (buffer-error "Attempt to pop from vector of zero (soft) length.") (vector-pop obj)))) @@ -110,9 +117,9 @@ (when (null new-pos) (setf new-pos start-pointer)) (cond ((< new-pos start-pointer) - (error "New position is less than (soft) beginning of the array.")) + (buffer-error "New position is less than (soft) beginning of the array.")) ((> new-pos (fill-pointer vector)) - (error "New position is greater than cache range, and than read-from-stream value")) + (buffer-error "New position is greater than cache range, and than read-from-stream value")) (t (setf cached-pos new-pos)))))) (defun rel-rewind (cache-iterator &optional (delta 1)) @@ -120,9 +127,9 @@ (with-slots (cached-vals cached-pos) cache-iterator (with-slots (vector start-pointer) cached-vals (cond ((< (- cached-pos delta) start-pointer) - (error "New position is less than (soft) beginning of the array.")) + (buffer-error "New position is less than (soft) beginning of the array.")) ((> (- cached-pos delta) (fill-pointer vector)) - (error "New position is greater than cache range, and than read-from-stream value")) + (buffer-error "New position is greater than cache range, and than read-from-stream value")) (t (setf cached-pos (- cached-pos delta))))))) @@ -165,7 +172,7 @@ (rewind ,iter ,g!-cached-pos))) ,@body))) -(defun print-iter-state (cached-iter) +(defun print-iter-state (&optional (cached-iter the-iter)) (with-slots (cached-vals cached-pos) cached-iter (with-slots (start-pointer vector) cached-vals (format t "Pos is: ~a, Start is: ~a, Cache contents is ~a, the-pos is: ~a, the-length is: ~a~%" diff --git a/src/macro.lisp b/src/macro.lisp index b84c8a1..3b81b93 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -52,6 +52,11 @@ `(descend-with-rule ',sym)))))) ,@body)) +(defmacro the-position-boundary (&body body) + `(let* ((the-position (+ the-position the-length)) + (the-length 0)) + ,@body)) + (defun! make-rule-lambda (name args body) (multiple-value-bind (reqs opts rest kwds allow-other-keys auxs kwds-p) (parse-ordinary-lambda-list args) (declare (ignore kwds)) @@ -59,8 +64,7 @@ (if allow-other-keys (error "&ALLOW-OTHER-KEYS is not supported")) (if auxs (error "&AUX variables are not supported, use LET")) `(named-lambda ,(intern (strcat "ESRAP-" name)) (,@args) - (let* ((the-position (+ the-position the-length)) - (the-length 0)) + (the-position-boundary (with-cached-result (,name ,@reqs ,@(if rest `(,rest) @@ -109,7 +113,7 @@ (block ,g!-ordered-choice (let (,g!-parse-errors) ,@(mapcar (lambda (clause) - `(let ((the-length 0)) + `(the-position-boundary (print-iter-state the-iter) (with-saved-iter-state (the-iter) (handler-case (return-from ,g!-ordered-choice (values ,clause the-length)) @@ -128,24 +132,31 @@ (defmacro ! (expr) "Succeeds, whenever parsing of EXPR fails. Does not consume, returns NIL, for compatibility with TEXT" - `(progn (let ((the-length 0)) - (handler-case ,expr - (simple-esrap-error () nil) - (:no-error (result &optional the-length) - (declare (ignore result the-length)) - (fail-parse "Clause under non-consuming negation succeeded.")))) + `(progn (the-position-boundary + (with-saved-iter-state (the-iter) + (handler-case ,expr + (simple-esrap-error () + (restore-iter-state) + nil) + (:no-error (result &optional the-length) + (declare (ignore result the-length)) + (fail-parse "Clause under non-consuming negation succeeded."))))) (make-result nil 0))) (defmacro !! (expr) "Succeeds, whenever parsing of EXPR fails. Consumes, assumes than EXPR parses just one character." - `(progn (let ((the-length 0)) - (handler-case ,expr - (simple-esrap-error () nil) - (:no-error (result &optional the-length) - (declare (ignore result the-length)) - (fail-parse "Clause under consuming negation succeeded.")))) + `(progn (the-position-boundary + (with-saved-iter-state (the-iter) + (handler-case ,expr + (simple-esrap-error () + (restore-iter-state) + nil) + (:no-error (result &optional the-length) + (declare (ignore result the-length)) + (fail-parse "Clause under consuming negation succeeded."))))) ;; TODO : here was a check about EOF. How should I properly address this with streams? - (make-result 'caboom! 1))) + (if (not (eof-p)) + (descend-with-rule 'any-token)))) (defmacro! times (subexpr &key from upto exactly) @@ -158,8 +169,7 @@ (multiple-value-bind (,g!-subresult ,g!-the-length) (with-saved-iter-state (the-iter) (format t " Inside subexpression:~%") - (handler-case (let* ((the-position (+ the-position the-length)) - (the-length 0)) + (handler-case (the-position-boundary (let ((subexpr ,subexpr)) (format t " succeeding ~s ~a~%" subexpr the-length) (print-iter-state the-iter) @@ -202,30 +212,41 @@ (defmacro! ? (subexpr) `(multiple-value-bind (,g!-result ,g!-the-length) (block ,g!-? - (let ((the-length 0)) - (handler-case ,subexpr - (simple-esrap-error () (values nil nil)) - (:no-error (result) (return-from ,g!-? (make-result result)))))) + (the-position-boundary + (with-saved-iter-state (the-iter) + (handler-case ,subexpr + (simple-esrap-error () + (restore-iter-state) + (values nil nil)) + (:no-error (result) (return-from ,g!-? (make-result result the-length))))))) (when ,g!-the-length (incf the-length ,g!-the-length)) ,g!-result)) (defmacro & (subexpr) - `(make-result (let ((the-length 0)) - ,subexpr))) + `(make-result (the-position-boundary + (with-saved-iter-state (the-iter) + (let ((it ,subexpr)) + (restore-iter-state) + it))))) + (defmacro -> (subexpr) (if (and (symbolp subexpr) (equal (string subexpr) "EOF")) - `(descend-with-rule 'eof) - `(progn (let ((the-length 0)) - ,subexpr) + `(progn (descend-with-rule 'eof) nil) + `(progn (the-position-boundary + (with-saved-iter-state (the-iter) + ,subexpr + (restore-iter-state))) (make-result nil)))) (defmacro! <- (subexpr) (if (and (symbolp subexpr) (equal (string subexpr) "SOF")) - `(descend-with-rule 'sof) - `(let ((the-length 0)) - (rel-rewind the-iter) + `(progn (descend-with-rule 'sof) nil) + `(the-position-boundary + (handler-case (rel-rewind the-iter) + (buffer-error () + (fail-parse "Can't rewind back even by 1 token"))) (let ((,g!-result ,subexpr)) (if (equal the-length 1) (make-result nil) diff --git a/src/memoization.lisp b/src/memoization.lisp index 394c1f2..1c206a8 100644 --- a/src/memoization.lisp +++ b/src/memoization.lisp @@ -81,12 +81,13 @@ :position ,g!-position :nonterminal ',symbol :path (reverse *nonterminal-stack*))) - (,g!-result (format t "Using result from cache: ~a ~a ~a~%" ',symbol ,g!-position ,g!-result) + (,g!-result (format t "Using result from cache: ~a (~{~a~^ ~}) ~a ~a~%" + ',symbol ,g!-args ,g!-position ,g!-result) (if (failed-parse-p ,g!-result) (error ,g!-result) (values (car ,g!-result) (cdr ,g!-result)))) (t - (format t "Calculating result anew: ~a ~a ~a~%" ',symbol ,g!-position ,g!-result) + (format t "Calculating result anew: ~a (~{~a~^ ~}) ~a ~a~%" ',symbol ,g!-args ,g!-position ,g!-result) ;; First mark this pair with :LEFT-RECURSION to detect left-recursion, ;; then compute the result and cache that. (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) :left-recursion) diff --git a/tests/rules.lisp b/tests/rules.lisp index d4f0dcb..85bf6a9 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -78,7 +78,11 @@ (list (? whitespace) (|| (& #\,) (! character)))))) (defrule list-of-integers () - (let ((it (|| (list integer #\, list-of-integers) + (let ((it (|| (list integer + #\, + (progn (format t (literal-string "I'm here!~%")) + (esrap-liquid::print-iter-state) + list-of-integers)) integer))) (if (integerp it) (list it) diff --git a/tests/tests.lisp b/tests/tests.lisp index fbefd32..5eb2f95 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -22,6 +22,9 @@ ) (test smoke + (is (equal "" (parse 'empty-line #?"\n"))) + (is (equal "asdf" (parse 'trimmed-line #?"asdf"))) + (is (equal "asdf" (parse 'trimmed-line #?" asdf "))) (is (equal '("1," "2," "" "3," "4.") (parse 'trimmed-lines "1, 2, From 3b7e2abb86b5b95da47e583ecf6f064d810b6b08 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Tue, 17 Feb 2015 12:17:30 +0100 Subject: [PATCH 57/95] Add abc-or-def test --- tests/rules.lisp | 5 +++-- tests/tests.lisp | 2 ++ 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/tests/rules.lisp b/tests/rules.lisp index 85bf6a9..e948548 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -265,5 +265,6 @@ #\) (cons c!-int c!-rc)) - - +(defrule abc-or-def () + (|| (list #\a #\b #\c) + (list #\d #\e #\f))) \ No newline at end of file diff --git a/tests/tests.lisp b/tests/tests.lisp index 5eb2f95..9e7570b 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -34,6 +34,8 @@ (is (eql 123 (parse 'integer " 123"))) (is (eql 123 (parse 'integer " 123 "))) (is (eql 123 (parse 'integer "123 "))) + (is (equal '(#\a #\b #\c) (parse abc-or-def "abc"))) + (is (equal '(#\d #\e #\f) (parse abc-or-def "def"))) (is (equal '(123 45 6789 0) (parse 'list-of-integers "123, 45 , 6789, 0"))) (is (equal '(123 45 6789 0) (parse 'list-of-integers " 123 ,45,6789, 0 ")))) From e14b17017bab91f37336b4095c6e7f4838493604 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Tue, 17 Feb 2015 17:58:08 +0100 Subject: [PATCH 58/95] Add nice debugging output on demand --- src/basic-rules.lisp | 8 +- src/conditions.lisp | 36 +++++++- src/esrap.lisp | 23 ++--- src/macro.lisp | 212 +++++++++++++++++++++++-------------------- src/memoization.lisp | 5 +- 5 files changed, 167 insertions(+), 117 deletions(-) diff --git a/src/basic-rules.lisp b/src/basic-rules.lisp index 322b4a9..050ffee 100644 --- a/src/basic-rules.lisp +++ b/src/basic-rules.lisp @@ -41,12 +41,12 @@ (def-nocontext-rule character (char) (let ((it (handler-case (next-iter the-iter) (stop-iteration () (fail-parse (literal-string "EOF reached while trying to parse character.")))))) - (format t (literal-string " in character: ~s ~s~%") it char) - (print-iter-state the-iter) + ;; (format t (literal-string " in character: ~s ~s~%") it char) + ;; (print-iter-state the-iter) (if (not char) (make-result it 1) (if (char= it char) - (progn (format t (literal-string " succeeding in character!~%")) + (progn ;; (format t (literal-string " succeeding in character!~%")) (make-result it 1)) (fail-parse-format (literal-string "Char ~a is not equal to desired char ~a") it char))))) @@ -58,7 +58,5 @@ any-string string)))) -(defun joinl (joinee lst) - (format nil (strcat "~{~a~^" joinee "~}") lst)) diff --git a/src/conditions.lisp b/src/conditions.lisp index ac32f6d..94d7c1f 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -7,6 +7,38 @@ (in-package :esrap-liquid) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *debug* t)) + +(defparameter *tracing-indent* 0) + +(defun joinl (joinee lst) + (format nil (concatenate 'string "~{~a~^" joinee "~}") lst)) +(defun join (joinee &rest lst) + (joinl joinee lst)) + +(defmacro tracing-init (&body body) + (if *debug* + `(let ((*tracing-indent* 0)) + ,@body) + `(progn ,@body))) + +(defmacro tracing-level (&body body) + (if *debug* + `(let ((*tracing-indent* (+ *tracing-indent* 4))) + ,@body) + `(progn ,@body))) + +(defmacro!! if-debug (format-str &rest args) + (with-macro-character (#\" (get-macro-character #\" nil)) + (call-next-method)) + (if *debug* + `(format t ,(join "" "~a" format-str "~%") + (make-string *tracing-indent* :initial-element #\space) + ,@args))) + + + (define-condition esrap-error (parse-error) ((text :initarg :text :initform nil :reader esrap-error-text) (position :initarg :position :initform nil :reader esrap-error-position) @@ -76,10 +108,12 @@ the error occurred.")) (defmacro fail-parse-format (&optional (reason "No particular reason.") &rest args) `(let ((formatted-reason (apply #'format `(nil ,,reason ,,@args)))) + (if-debug "fail: ~a" formatted-reason) (simple-esrap-error (+ the-position the-length) formatted-reason ,reason ,@args))) (defmacro fail-parse (&optional (reason "No particular reason.")) - `(simple-esrap-error (+ the-position the-length) ,reason ,reason)) + `(progn (if-debug "fail: ~a" ,reason) + (simple-esrap-error (+ the-position the-length) ,reason ,reason))) (define-condition left-recursion (esrap-error) ((nonterminal :initarg :nonterminal :initform nil :reader left-recursion-nonterminal) diff --git a/src/esrap.lisp b/src/esrap.lisp index 84e2c2a..9524961 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -25,17 +25,18 @@ (*cache* (make-cache)) (the-position 0) (the-length 0)) - (with-tmp-rule (tmp-rule expression) - (let ((result (handler-case (descend-with-rule tmp-rule) - (simple-esrap-error (e) - (if junk-allowed - (values nil 0) - (error e)))))) - (when (not junk-allowed) - (handler-case (descend-with-rule 'eof) - (simple-esrap-error () - (fail-parse "Didnt make it to the end of the text")))) - (values result the-length))))) + (tracing-init + (with-tmp-rule (tmp-rule expression) + (let ((result (handler-case (descend-with-rule tmp-rule) + (simple-esrap-error (e) + (if junk-allowed + (values nil 0) + (error e)))))) + (when (not junk-allowed) + (handler-case (descend-with-rule 'eof) + (simple-esrap-error () + (fail-parse "Didnt make it to the end of the text")))) + (values result the-length)))))) (defun mk-esrap-iter-from-string (str start end) (mk-cache-iter (mk-string-iter (subseq str start end)))) diff --git a/src/macro.lisp b/src/macro.lisp index 3b81b93..b2a8a86 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -10,7 +10,9 @@ `(multiple-value-bind (,g!-it ,g!-got) (gethash ,o!-sym *rules*) (if (not ,g!-got) (error "Undefined rule: ~s" ,o!-sym) - (multiple-value-bind (result new-length) (funcall ,g!-it ,@args) + (multiple-value-bind (result new-length) + (tracing-level + (funcall ,g!-it ,@args)) (incf the-length new-length) result)))) @@ -82,7 +84,7 @@ (with-esrap-variable-transformer (let ((c!-vars (make-hash-table))) (declare (special c!-vars)) - (format t "I'm starting to actually expand!~%") + (format t "I'm starting to actually expand ~a!~%" name) ;; TODO: bug - C!-vars values are kept between different execution of a rule! (let ((pre-body (macroexpand-cc-all-transforming-undefs (make-rule-lambda name args body) @@ -104,6 +106,7 @@ (defmacro! make-result (result &optional (length 0)) ;; We must preserve the semantics, that computation of results occurs before increment of length `(let ((,g!-result ,result)) + (if-debug "success: ~s" ,g!-result) (values ,g!-result (incf the-length ,length)))) @@ -111,81 +114,88 @@ `(multiple-value-bind (,g!-result ,g!-the-length) ;; All this tricky business with BLOCK just for automatic LENGTH tracking. (block ,g!-ordered-choice - (let (,g!-parse-errors) - ,@(mapcar (lambda (clause) - `(the-position-boundary - (print-iter-state the-iter) - (with-saved-iter-state (the-iter) - (handler-case (return-from ,g!-ordered-choice (values ,clause the-length)) - (simple-esrap-error (e) - (restore-iter-state) - (push e ,g!-parse-errors)))))) - clauses) - (fail-parse (joinl "~%" - (mapcar (lambda (x) - (slot-value x 'reason)) - (nreverse ,g!-parse-errors)))))) - (format t "After ||: ~%") (print-iter-state the-iter) + (tracing-level + (if-debug "||") + (let (,g!-parse-errors) + ,@(mapcar (lambda (clause) + `(the-position-boundary + ;; (print-iter-state the-iter) + (with-saved-iter-state (the-iter) + (handler-case (return-from ,g!-ordered-choice (values ,clause the-length)) + (simple-esrap-error (e) + (restore-iter-state) + (push e ,g!-parse-errors)))))) + clauses) + (fail-parse (joinl "~%" + (mapcar (lambda (x) + (slot-value x 'reason)) + (nreverse ,g!-parse-errors))))))) + ;; (format t "After ||: ~%") (print-iter-state the-iter) (incf the-length ,g!-the-length) ,g!-result)) (defmacro ! (expr) "Succeeds, whenever parsing of EXPR fails. Does not consume, returns NIL, for compatibility with TEXT" - `(progn (the-position-boundary - (with-saved-iter-state (the-iter) - (handler-case ,expr - (simple-esrap-error () - (restore-iter-state) - nil) - (:no-error (result &optional the-length) - (declare (ignore result the-length)) - (fail-parse "Clause under non-consuming negation succeeded."))))) - (make-result nil 0))) + `(tracing-level + (if-debug "!") + (the-position-boundary + (with-saved-iter-state (the-iter) + (handler-case ,expr + (simple-esrap-error () + (restore-iter-state) + nil) + (:no-error (result &optional the-length) + (declare (ignore result the-length)) + (fail-parse "Clause under non-consuming negation succeeded."))))) + (make-result nil 0))) (defmacro !! (expr) "Succeeds, whenever parsing of EXPR fails. Consumes, assumes than EXPR parses just one character." - `(progn (the-position-boundary - (with-saved-iter-state (the-iter) - (handler-case ,expr - (simple-esrap-error () - (restore-iter-state) - nil) - (:no-error (result &optional the-length) - (declare (ignore result the-length)) - (fail-parse "Clause under consuming negation succeeded."))))) - ;; TODO : here was a check about EOF. How should I properly address this with streams? - (if (not (eof-p)) - (descend-with-rule 'any-token)))) + `(tracing-level + (if-debug "!!") + (the-position-boundary + (with-saved-iter-state (the-iter) + (handler-case ,expr + (simple-esrap-error () + (restore-iter-state) + nil) + (:no-error (result &optional the-length) + (declare (ignore result the-length)) + (fail-parse "Clause under consuming negation succeeded."))))) + ;; TODO : here was a check about EOF. How should I properly address this with streams? + (if (not (eof-p)) + (descend-with-rule 'any-token)))) (defmacro! times (subexpr &key from upto exactly) (flet ((frob (condition) `(let (,g!-result) - (iter ,(if (or upto exactly) - `(for ,g!-i from 1 to ,(or upto exactly))) - (format t "Next TIMES: ") - (print-iter-state the-iter) - (multiple-value-bind (,g!-subresult ,g!-the-length) - (with-saved-iter-state (the-iter) - (format t " Inside subexpression:~%") - (handler-case (the-position-boundary - (let ((subexpr ,subexpr)) - (format t " succeeding ~s ~a~%" subexpr the-length) - (print-iter-state the-iter) - (values subexpr the-length))) - (simple-esrap-error () - (format t " failing~%") - (restore-iter-state) - (finish)))) - (if-first-time nil - (if (equal ,g!-the-length 0) - (terminate))) - (push ,g!-subresult ,g!-result) - (incf the-length ,g!-the-length)) - (finally (if ,condition - (return (make-result (nreverse ,g!-result))) - (fail-parse "Greedy repetition failed."))))))) + (tracing-level + (iter ,(if (or upto exactly) + `(for ,g!-i from 1 to ,(or upto exactly))) + (if-debug "TIMES") + ;; (print-iter-state the-iter) + (multiple-value-bind (,g!-subresult ,g!-the-length) + (with-saved-iter-state (the-iter) + ;; (format t " Inside subexpression:~%") + (handler-case (the-position-boundary + (let ((subexpr ,subexpr)) + ;; (format t " succeeding ~s ~a~%" subexpr the-length) + ;; (print-iter-state the-iter) + (values subexpr the-length))) + (simple-esrap-error () + ;; (format t " failing~%") + (restore-iter-state) + (finish)))) + (if-first-time nil + (if (equal ,g!-the-length 0) + (terminate))) + (push ,g!-subresult ,g!-result) + (incf the-length ,g!-the-length)) + (finally (if ,condition + (return (make-result (nreverse ,g!-result))) + (fail-parse "Greedy repetition failed.")))))))) (cond (exactly (if (or from upto) (error "keywords :EXACTLY and :FROM/:UPTO are mutually exclusive.") (frob `(equal (length ,g!-result) ,exactly)))) @@ -210,47 +220,55 @@ `(progn ,start (prog1 ,meat ,end))) (defmacro! ? (subexpr) - `(multiple-value-bind (,g!-result ,g!-the-length) - (block ,g!-? - (the-position-boundary - (with-saved-iter-state (the-iter) - (handler-case ,subexpr - (simple-esrap-error () - (restore-iter-state) - (values nil nil)) - (:no-error (result) (return-from ,g!-? (make-result result the-length))))))) - (when ,g!-the-length - (incf the-length ,g!-the-length)) - ,g!-result)) + `(tracing-level + (if-debug "?") + (multiple-value-bind (,g!-result ,g!-the-length) + (block ,g!-? + (the-position-boundary + (with-saved-iter-state (the-iter) + (handler-case ,subexpr + (simple-esrap-error () + (restore-iter-state) + (values nil nil)) + (:no-error (result) (return-from ,g!-? (make-result result the-length))))))) + (when ,g!-the-length + (incf the-length ,g!-the-length)) + ,g!-result))) (defmacro & (subexpr) - `(make-result (the-position-boundary - (with-saved-iter-state (the-iter) - (let ((it ,subexpr)) - (restore-iter-state) - it))))) + `(tracing-level + (if-debug "&") + (make-result (the-position-boundary + (with-saved-iter-state (the-iter) + (let ((it ,subexpr)) + (restore-iter-state) + it)))))) (defmacro -> (subexpr) - (if (and (symbolp subexpr) (equal (string subexpr) "EOF")) - `(progn (descend-with-rule 'eof) nil) - `(progn (the-position-boundary - (with-saved-iter-state (the-iter) - ,subexpr - (restore-iter-state))) - (make-result nil)))) + (tracing-level + (if-debug "->") + (if (and (symbolp subexpr) (equal (string subexpr) "EOF")) + `(progn (descend-with-rule 'eof) nil) + `(progn (the-position-boundary + (with-saved-iter-state (the-iter) + ,subexpr + (restore-iter-state))) + (make-result nil))))) (defmacro! <- (subexpr) - (if (and (symbolp subexpr) (equal (string subexpr) "SOF")) - `(progn (descend-with-rule 'sof) nil) - `(the-position-boundary - (handler-case (rel-rewind the-iter) - (buffer-error () - (fail-parse "Can't rewind back even by 1 token"))) - (let ((,g!-result ,subexpr)) - (if (equal the-length 1) - (make-result nil) - (fail-parse "Parsing of subexpr took more than 1 token.")))))) + (tracing-level + (if-debug "<-") + (if (and (symbolp subexpr) (equal (string subexpr) "SOF")) + `(progn (descend-with-rule 'sof) nil) + `(the-position-boundary + (handler-case (rel-rewind the-iter) + (buffer-error () + (fail-parse "Can't rewind back even by 1 token"))) + (let ((,g!-result ,subexpr)) + (if (equal the-length 1) + (make-result nil) + (fail-parse "Parsing of subexpr took more than 1 token."))))))) (defmacro! cond-parse (&rest clauses) `(|| ,@(mapcar (lambda (clause) diff --git a/src/memoization.lisp b/src/memoization.lisp index 1c206a8..7e76bb7 100644 --- a/src/memoization.lisp +++ b/src/memoization.lisp @@ -81,13 +81,12 @@ :position ,g!-position :nonterminal ',symbol :path (reverse *nonterminal-stack*))) - (,g!-result (format t "Using result from cache: ~a (~{~a~^ ~}) ~a ~a~%" - ',symbol ,g!-args ,g!-position ,g!-result) + (,g!-result (if-debug "~a (~{~s~^ ~}) ~a ~a: CACHED" ',symbol ,g!-args ,g!-position ,g!-result) (if (failed-parse-p ,g!-result) (error ,g!-result) (values (car ,g!-result) (cdr ,g!-result)))) (t - (format t "Calculating result anew: ~a (~{~a~^ ~}) ~a ~a~%" ',symbol ,g!-args ,g!-position ,g!-result) + (if-debug "~a (~{~s~^ ~}) ~a ~a: NEW" ',symbol ,g!-args ,g!-position ,g!-result) ;; First mark this pair with :LEFT-RECURSION to detect left-recursion, ;; then compute the result and cache that. (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) :left-recursion) From 4c33d79fc8dd9d07aac9f1b0d0d4adc572e2fd6c Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Tue, 17 Feb 2015 18:31:20 +0100 Subject: [PATCH 59/95] Towards tracing error in position increment --- src/iterators.lisp | 14 ++++++++++++-- src/memoization.lisp | 5 ++++- tests/tests.lisp | 6 ++++-- 3 files changed, 20 insertions(+), 5 deletions(-) diff --git a/src/iterators.lisp b/src/iterators.lisp index 7c2309e..36df7cc 100644 --- a/src/iterators.lisp +++ b/src/iterators.lisp @@ -132,6 +132,16 @@ (buffer-error "New position is greater than cache range, and than read-from-stream value")) (t (setf cached-pos (- cached-pos delta))))))) +(defun fast-forward (cache-iterator &optional (delta 1)) + "Relative fast-forward" + (with-slots (cached-vals cached-pos) cache-iterator + (with-slots (vector start-pointer) cached-vals + (cond ((< (+ cached-pos delta) start-pointer) + (buffer-error "New position is less than (soft) beginning of the array.")) + ((> (+ cached-pos delta) (fill-pointer vector)) + (buffer-error "New position is greater than cache range, and than read-from-stream value")) + (t (setf cached-pos (+ cached-pos delta))))))) + (defmethod next-iter ((iter cache-iterator)) (with-slots (cached-vals cached-pos sub-iter) iter @@ -175,5 +185,5 @@ (defun print-iter-state (&optional (cached-iter the-iter)) (with-slots (cached-vals cached-pos) cached-iter (with-slots (start-pointer vector) cached-vals - (format t "Pos is: ~a, Start is: ~a, Cache contents is ~a, the-pos is: ~a, the-length is: ~a~%" - cached-pos start-pointer vector the-position the-length)))) \ No newline at end of file + (if-debug " p ~a s ~a f ~a P ~a L ~a" + cached-pos start-pointer (fill-pointer vector) the-position the-length)))) diff --git a/src/memoization.lisp b/src/memoization.lisp index 7e76bb7..350e4e7 100644 --- a/src/memoization.lisp +++ b/src/memoization.lisp @@ -82,11 +82,14 @@ :nonterminal ',symbol :path (reverse *nonterminal-stack*))) (,g!-result (if-debug "~a (~{~s~^ ~}) ~a ~a: CACHED" ',symbol ,g!-args ,g!-position ,g!-result) + (print-iter-state the-iter) (if (failed-parse-p ,g!-result) (error ,g!-result) - (values (car ,g!-result) (cdr ,g!-result)))) + (progn (fast-forward the-iter (cdr ,g!-result)) + (values (car ,g!-result) (cdr ,g!-result))))) (t (if-debug "~a (~{~s~^ ~}) ~a ~a: NEW" ',symbol ,g!-args ,g!-position ,g!-result) + (print-iter-state the-iter) ;; First mark this pair with :LEFT-RECURSION to detect left-recursion, ;; then compute the result and cache that. (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) :left-recursion) diff --git a/tests/tests.lisp b/tests/tests.lisp index 9e7570b..ad21d98 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -34,8 +34,10 @@ (is (eql 123 (parse 'integer " 123"))) (is (eql 123 (parse 'integer " 123 "))) (is (eql 123 (parse 'integer "123 "))) - (is (equal '(#\a #\b #\c) (parse abc-or-def "abc"))) - (is (equal '(#\d #\e #\f) (parse abc-or-def "def"))) + (is (equal '(#\a #\b #\c) (parse 'abc-or-def "abc"))) + (is (equal '(#\d #\e #\f) (parse 'abc-or-def "def"))) + (is (equal '(123 45) (parse 'list-of-integers "123,45"))) + (is (equal '(1 2) (parse 'list-of-integers "1, 2"))) (is (equal '(123 45 6789 0) (parse 'list-of-integers "123, 45 , 6789, 0"))) (is (equal '(123 45 6789 0) (parse 'list-of-integers " 123 ,45,6789, 0 ")))) From b247d16ec029fb580701cb4fd92a61f486844ab1 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Tue, 17 Feb 2015 19:11:00 +0100 Subject: [PATCH 60/95] Add triple a test --- tests/rules.lisp | 4 ++-- tests/tests.lisp | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/tests/rules.lisp b/tests/rules.lisp index 85bf6a9..0f2f81e 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -265,5 +265,5 @@ #\) (cons c!-int c!-rc)) - - +(defrule triple-a () + (list #\a #\a #\a)) \ No newline at end of file diff --git a/tests/tests.lisp b/tests/tests.lisp index 5eb2f95..f21d116 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -34,6 +34,7 @@ (is (eql 123 (parse 'integer " 123"))) (is (eql 123 (parse 'integer " 123 "))) (is (eql 123 (parse 'integer "123 "))) + (is (equal '(#\a #\a #\a) (parse 'triple-a "aaa"))) (is (equal '(123 45 6789 0) (parse 'list-of-integers "123, 45 , 6789, 0"))) (is (equal '(123 45 6789 0) (parse 'list-of-integers " 123 ,45,6789, 0 ")))) From 9552eb7894461d5895ee4490b3c81d2372f7da30 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Tue, 17 Feb 2015 21:05:15 +0100 Subject: [PATCH 61/95] Make smoke tests work --- src/basic-rules.lisp | 2 +- src/conditions.lisp | 2 +- src/esrap.lisp | 1 + src/iterators.lisp | 11 ++++--- src/macro.lisp | 73 +++++++++++++++++++++++--------------------- src/memoization.lisp | 33 ++++++++++---------- tests/rules.lisp | 2 +- 7 files changed, 67 insertions(+), 57 deletions(-) diff --git a/src/basic-rules.lisp b/src/basic-rules.lisp index 050ffee..39ecac5 100644 --- a/src/basic-rules.lisp +++ b/src/basic-rules.lisp @@ -48,7 +48,7 @@ (if (char= it char) (progn ;; (format t (literal-string " succeeding in character!~%")) (make-result it 1)) - (fail-parse-format (literal-string "Char ~a is not equal to desired char ~a") it char))))) + (fail-parse-format (literal-string "Char ~s is not equal to desired char ~s") it char))))) (def-nocontext-rule string (string) (let ((any-string (any-string (length string)))) diff --git a/src/conditions.lisp b/src/conditions.lisp index 94d7c1f..cd6c306 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -8,7 +8,7 @@ (in-package :esrap-liquid) (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter *debug* t)) + (defparameter *debug* nil)) (defparameter *tracing-indent* 0) diff --git a/src/esrap.lisp b/src/esrap.lisp index 9524961..17ad474 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -32,6 +32,7 @@ (if junk-allowed (values nil 0) (error e)))))) + (if-debug "after tmp-rule") (when (not junk-allowed) (handler-case (descend-with-rule 'eof) (simple-esrap-error () diff --git a/src/iterators.lisp b/src/iterators.lisp index 36df7cc..91f3a90 100644 --- a/src/iterators.lisp +++ b/src/iterators.lisp @@ -36,8 +36,9 @@ (define-condition buffer-error (error) ((msg :initarg :msg :initform nil))) -(defun buffer-error (str) - (error 'buffer-error :msg str)) +(defun buffer-error (str &rest args) + (error 'buffer-error :msg (apply #'format (append (list nil str) + args)))) (defmethod soft-shrink ((obj buffer-vector) (num-elts-discarded integer)) @@ -137,9 +138,11 @@ (with-slots (cached-vals cached-pos) cache-iterator (with-slots (vector start-pointer) cached-vals (cond ((< (+ cached-pos delta) start-pointer) - (buffer-error "New position is less than (soft) beginning of the array.")) + (buffer-error "New position ~a is less than (soft) beginning of the array ~a." + (+ cached-pos delta) start-pointer)) ((> (+ cached-pos delta) (fill-pointer vector)) - (buffer-error "New position is greater than cache range, and than read-from-stream value")) + (buffer-error "New position ~a is greater than cache range, and than read-from-stream value ~a" + (+ cached-pos delta) (fill-pointer vector))) (t (setf cached-pos (+ cached-pos delta))))))) diff --git a/src/macro.lisp b/src/macro.lisp index b2a8a86..daf2664 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -10,11 +10,8 @@ `(multiple-value-bind (,g!-it ,g!-got) (gethash ,o!-sym *rules*) (if (not ,g!-got) (error "Undefined rule: ~s" ,o!-sym) - (multiple-value-bind (result new-length) - (tracing-level - (funcall ,g!-it ,@args)) - (incf the-length new-length) - result)))) + (tracing-level + (funcall ,g!-it ,@args))))) (defmacro with-esrap-reader-context (&body body) `(let ((char-reader (get-dispatch-macro-character #\# #\\)) @@ -66,16 +63,14 @@ (if allow-other-keys (error "&ALLOW-OTHER-KEYS is not supported")) (if auxs (error "&AUX variables are not supported, use LET")) `(named-lambda ,(intern (strcat "ESRAP-" name)) (,@args) - (the-position-boundary - (with-cached-result (,name ,@reqs - ,@(if rest - `(,rest) - (iter (for (opt-name opt-default opt-supplied-p) in opts) - (collect opt-name) - (if opt-supplied-p - (collect opt-supplied-p))))) - (values (progn ,@body) - the-length)))))) + (with-cached-result (,name ,@reqs + ,@(if rest + `(,rest) + (iter (for (opt-name opt-default opt-supplied-p) in opts) + (collect opt-name) + (if opt-supplied-p + (collect opt-supplied-p))))) + ,@body)))) (defmacro!! %defrule (name args &body body &environment env) @@ -103,25 +98,32 @@ (setf (gethash ',name *rule-context-sensitivity*) nil))) -(defmacro! make-result (result &optional (length 0)) +(defmacro! make-result (result &optional (length 0) beginning) ;; We must preserve the semantics, that computation of results occurs before increment of length `(let ((,g!-result ,result)) - (if-debug "success: ~s" ,g!-result) - (values ,g!-result (incf the-length ,length)))) + (incf the-length ,length) + (if-debug "~asuccess: ~s ~a" ,(if beginning + #?"$(beginning) " + "") + ,g!-result the-length) + ,g!-result)) (defmacro! || (&rest clauses) - `(multiple-value-bind (,g!-result ,g!-the-length) - ;; All this tricky business with BLOCK just for automatic LENGTH tracking. - (block ,g!-ordered-choice - (tracing-level - (if-debug "||") + `(tracing-level + (if-debug "||") + (multiple-value-bind (,g!-result ,g!-the-length) + ;; All this tricky business with BLOCK just for automatic LENGTH tracking. + (block ,g!-ordered-choice (let (,g!-parse-errors) ,@(mapcar (lambda (clause) `(the-position-boundary ;; (print-iter-state the-iter) (with-saved-iter-state (the-iter) - (handler-case (return-from ,g!-ordered-choice (values ,clause the-length)) + (handler-case (return-from ,g!-ordered-choice + (let ((res ,clause)) + ;; (if-debug "|| pre-succeeding") + (values res the-length))) (simple-esrap-error (e) (restore-iter-state) (push e ,g!-parse-errors)))))) @@ -129,10 +131,10 @@ (fail-parse (joinl "~%" (mapcar (lambda (x) (slot-value x 'reason)) - (nreverse ,g!-parse-errors))))))) - ;; (format t "After ||: ~%") (print-iter-state the-iter) - (incf the-length ,g!-the-length) - ,g!-result)) + (nreverse ,g!-parse-errors)))))) + (if-debug "|| aftermath ~a ~a" the-length ,g!-the-length) + (incf the-length ,g!-the-length) + ,g!-result))) (defmacro ! (expr) @@ -210,10 +212,12 @@ `(times ,subexpr :from 1)) (defmacro! pred (predicate subexpr) - `(let ((,g!-it ,subexpr)) - (if (funcall ,predicate ,g!-it) - ,g!-it - (fail-parse "Predicate test failed")))) + `(tracing-level + (if-debug "PREDICATE") + (let ((,g!-it ,subexpr)) + (if (funcall ,predicate ,g!-it) + ,g!-it + (fail-parse "Predicate test failed"))))) (defmacro progm (start meat end) "Prog Middle." @@ -221,16 +225,17 @@ (defmacro! ? (subexpr) `(tracing-level - (if-debug "?") + (if-debug "? ~a ~a" the-position the-length) (multiple-value-bind (,g!-result ,g!-the-length) (block ,g!-? (the-position-boundary + (print-iter-state) (with-saved-iter-state (the-iter) (handler-case ,subexpr (simple-esrap-error () (restore-iter-state) (values nil nil)) - (:no-error (result) (return-from ,g!-? (make-result result the-length))))))) + (:no-error (result) (return-from ,g!-? (values result the-length))))))) (when ,g!-the-length (incf the-length ,g!-the-length)) ,g!-result))) diff --git a/src/memoization.lisp b/src/memoization.lisp index 350e4e7..4245b75 100644 --- a/src/memoization.lisp +++ b/src/memoization.lisp @@ -74,8 +74,6 @@ (,g!-position (+ the-position the-length)) (,g!-result (get-cached ',symbol ,g!-position ,g!-args ,g!-cache)) (*nonterminal-stack* (cons ',symbol *nonterminal-stack*))) - ;; (format t "hashassoc ~a~%" (hash->assoc ,g!-cache)) - ;; (format t "sym: ~a pos: ~a res: ~a~%" ',symbol ,g!-position ,g!-result) (cond ((eq :left-recursion ,g!-result) (error 'left-recursion :position ,g!-position @@ -85,24 +83,27 @@ (print-iter-state the-iter) (if (failed-parse-p ,g!-result) (error ,g!-result) - (progn (fast-forward the-iter (cdr ,g!-result)) - (values (car ,g!-result) (cdr ,g!-result))))) + (progn (incf the-length (cdr ,g!-result)) + (fast-forward the-iter (cdr ,g!-result)) + (car ,g!-result)))) (t (if-debug "~a (~{~s~^ ~}) ~a ~a: NEW" ',symbol ,g!-args ,g!-position ,g!-result) (print-iter-state the-iter) ;; First mark this pair with :LEFT-RECURSION to detect left-recursion, ;; then compute the result and cache that. (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) :left-recursion) - ;; (format t "hashassoc 2 ~a~%" (hash->assoc ,g!-cache)) - (multiple-value-bind (result length) (handler-case (locally ,@forms) - (simple-esrap-error (e) e)) + (multiple-value-bind (result length) + (handler-case (the-position-boundary + (values (progn ,@forms) the-length)) + (simple-esrap-error (e) (values e :error))) + ;; (if-debug "after evaluation anew ~a ~a" length the-length) ;; LENGTH is non-NIL only for successful parses - (if length - (progn (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) - (cons result length)) - ;; (format t "hashassoc 2.5 ~a~%" (hash->assoc ,g!-cache)) - (values result length)) - (progn (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) - result) - ;; (format t "hashassoc 3 ~a~%" (hash->assoc ,g!-cache)) - (error result)))))))) + (cond ((eq :error length) (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) + result) + (error result)) + ((null length) (error "For some reason, length is NIL in memoization")) + (t (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) + (cons result length)) + (incf the-length length) + (if-debug "after setting cache ~a" the-length) + result))))))) diff --git a/tests/rules.lisp b/tests/rules.lisp index ed34d32..8c1f7fe 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -80,7 +80,7 @@ (defrule list-of-integers () (let ((it (|| (list integer #\, - (progn (format t (literal-string "I'm here!~%")) + (progn ;; (format t (literal-string "I'm here!~%")) (esrap-liquid::print-iter-state) list-of-integers)) integer))) From 407466bcf429a36ec213ce77f329f4de73a7c409 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Tue, 17 Feb 2015 23:32:17 +0100 Subject: [PATCH 62/95] All tests, that were left, work, removed MATCH-START and MATCH-END --- src/basic-rules.lisp | 4 +++ src/conditions.lisp | 10 ++++-- src/esrap-env.lisp | 2 +- src/esrap.lisp | 9 +++-- src/macro.lisp | 47 ++++++++++++++------------ tests/tests.lisp | 79 +++++++++++++++++++++----------------------- 6 files changed, 84 insertions(+), 67 deletions(-) diff --git a/src/basic-rules.lisp b/src/basic-rules.lisp index 39ecac5..14f14c6 100644 --- a/src/basic-rules.lisp +++ b/src/basic-rules.lisp @@ -16,6 +16,10 @@ (rel-rewind the-iter) (fail-parse (literal-string "Not at the end of token stream."))))) +(defun eof-p () + (handler-case (descend-with-rule 'eof) + (simple-esrap-error () nil))) + (def-nocontext-rule sof () (if (start-of-iter-p the-iter) (make-result 'sof) diff --git a/src/conditions.lisp b/src/conditions.lisp index cd6c306..7211928 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -38,6 +38,12 @@ ,@args))) +(defun if-debug-fun (format-str &rest args) + (if *debug* + (apply #'format (append (list t (join "" "~a" format-str "~%") + (make-string *tracing-indent* :initial-element #\space)) + args)))) + (define-condition esrap-error (parse-error) ((text :initarg :text :initform nil :reader esrap-error-text) @@ -108,11 +114,11 @@ the error occurred.")) (defmacro fail-parse-format (&optional (reason "No particular reason.") &rest args) `(let ((formatted-reason (apply #'format `(nil ,,reason ,,@args)))) - (if-debug "fail: ~a" formatted-reason) + (if-debug "fail: ~a P ~a L ~a" formatted-reason the-position the-length) (simple-esrap-error (+ the-position the-length) formatted-reason ,reason ,@args))) (defmacro fail-parse (&optional (reason "No particular reason.")) - `(progn (if-debug "fail: ~a" ,reason) + `(progn (if-debug "fail: ~a: P ~a L ~a" ,reason the-position the-length) (simple-esrap-error (+ the-position the-length) ,reason ,reason))) (define-condition left-recursion (esrap-error) diff --git a/src/esrap-env.lisp b/src/esrap-env.lisp index cc9cf96..1ff793a 100644 --- a/src/esrap-env.lisp +++ b/src/esrap-env.lisp @@ -16,7 +16,7 @@ ,symbol ,args ,@body)))) (defun install-common-rules (hash-table) - (let ((common-rules '(any-string character string))) + (let ((common-rules '(any-string character string eof sof any-token))) (iter (for rule in common-rules) (setf (gethash rule hash-table) (gethash rule *rules*))))) diff --git a/src/esrap.lisp b/src/esrap.lisp index 17ad474..f3ab2fd 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -60,9 +60,14 @@ are allowed only if JUNK-ALLOWED is true." (gethash 'parse-token-iter cl-read-macro-tokens::*read-macro-tokens-instances*) (make-instance 'parse-reader-class :name 'parse-token-iter)) - (setf (gethash 'parse-token-iter *read-macro-tokens*) + (setf (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-classes*) + 'parse-reader-class + (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-instances*) + (make-instance 'parse-reader-class + :name 'parse)) + (setf (gethash 'parse *read-macro-tokens*) (lambda (stream token) - (read-handler (gethash 'parse-token-iter cl-read-macro-tokens::*read-macro-tokens-instances*) + (read-handler (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-instances*) stream token)))) diff --git a/src/macro.lisp b/src/macro.lisp index daf2664..e38bc43 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -79,7 +79,7 @@ (with-esrap-variable-transformer (let ((c!-vars (make-hash-table))) (declare (special c!-vars)) - (format t "I'm starting to actually expand ~a!~%" name) + (if-debug-fun "I'm starting to actually expand ~a!" name) ;; TODO: bug - C!-vars values are kept between different execution of a rule! (let ((pre-body (macroexpand-cc-all-transforming-undefs (make-rule-lambda name args body) @@ -128,6 +128,7 @@ (restore-iter-state) (push e ,g!-parse-errors)))))) clauses) + (if-debug "|| before failing P ~a L ~a" the-position the-length) (fail-parse (joinl "~%" (mapcar (lambda (x) (slot-value x 'reason)) @@ -140,16 +141,17 @@ (defmacro ! (expr) "Succeeds, whenever parsing of EXPR fails. Does not consume, returns NIL, for compatibility with TEXT" `(tracing-level - (if-debug "!") + (if-debug "! P ~a L ~a" the-position the-length) (the-position-boundary (with-saved-iter-state (the-iter) (handler-case ,expr (simple-esrap-error () (restore-iter-state) nil) - (:no-error (result &optional the-length) - (declare (ignore result the-length)) + (:no-error (result) + (declare (ignore result)) (fail-parse "Clause under non-consuming negation succeeded."))))) + (if-debug "! before result P ~a L ~a" the-position the-length) (make-result nil 0))) (defmacro !! (expr) @@ -162,12 +164,10 @@ (simple-esrap-error () (restore-iter-state) nil) - (:no-error (result &optional the-length) - (declare (ignore result the-length)) + (:no-error (result) + (declare (ignore result)) (fail-parse "Clause under consuming negation succeeded."))))) - ;; TODO : here was a check about EOF. How should I properly address this with streams? - (if (not (eof-p)) - (descend-with-rule 'any-token)))) + (descend-with-rule 'any-token))) (defmacro! times (subexpr &key from upto exactly) @@ -262,18 +262,23 @@ (make-result nil))))) (defmacro! <- (subexpr) - (tracing-level - (if-debug "<-") - (if (and (symbolp subexpr) (equal (string subexpr) "SOF")) - `(progn (descend-with-rule 'sof) nil) - `(the-position-boundary - (handler-case (rel-rewind the-iter) - (buffer-error () - (fail-parse "Can't rewind back even by 1 token"))) - (let ((,g!-result ,subexpr)) - (if (equal the-length 1) - (make-result nil) - (fail-parse "Parsing of subexpr took more than 1 token."))))))) + `(tracing-level + (if-debug "<-") + ,(if (and (symbolp subexpr) (equal (string subexpr) "SOF")) + `(progn (descend-with-rule 'sof) nil) + `(multiple-value-bind (,g!-res ,g!-len) + (the-position-boundary + (handler-case (rel-rewind the-iter) + (buffer-error () + (fail-parse "Can't rewind back even by 1 token"))) + (let ((,g!-result ,subexpr)) + (declare (ignore ,g!-result)) + (if (not (equal the-length 1)) + (fail-parse "Parsing of subexpr took more than 1 token.") + (values nil the-length)))) + (incf the-length ,g!-len) + ,g!-res)))) + (defmacro! cond-parse (&rest clauses) `(|| ,@(mapcar (lambda (clause) diff --git a/tests/tests.lisp b/tests/tests.lisp index d86c65a..3677534 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -42,17 +42,17 @@ (is (equal '(123 45 6789 0) (parse 'list-of-integers "123, 45 , 6789, 0"))) (is (equal '(123 45 6789 0) (parse 'list-of-integers " 123 ,45,6789, 0 ")))) -(test bounds.1 - (is (equal '("foo[0-3]") - (parse 'tokens/bounds.1 "foo"))) - (is (equal '("foo[0-3]" "bar[4-7]" "quux[11-15]") - (parse 'tokens/bounds.1 "foo bar quux")))) - -(test bounds.2 - (is (equal '("foo(0-3)") - (parse 'tokens/bounds.2 "foo"))) - (is (equal '("foo(0-3)" "bar(4-7)" "quux(11-15)") - (parse 'tokens/bounds.2 "foo bar quux")))) +;; (test bounds.1 +;; (is (equal '("foo[0-3]") +;; (parse 'tokens/bounds.1 "foo"))) +;; (is (equal '("foo[0-3]" "bar[4-7]" "quux[11-15]") +;; (parse 'tokens/bounds.1 "foo bar quux")))) + +;; (test bounds.2 +;; (is (equal '("foo(0-3)") +;; (parse 'tokens/bounds.2 "foo"))) +;; (is (equal '("foo(0-3)" "bar(4-7)" "quux(11-15)") +;; (parse 'tokens/bounds.2 "foo bar quux")))) (defmacro signals-esrap-error ((input position &optional messages) &body body) `(progn @@ -60,8 +60,8 @@ ,@body) (handler-case (progn ,@body) (esrap-liquid::esrap-error (condition) - (is (string= (esrap-liquid::esrap-error-text condition) ,input)) - (is (= (esrap-liquid::esrap-error-position condition) ,position)) + ;; (is (string= (esrap-liquid::esrap-error-text condition) ,input)) + ;; (is (= (esrap-liquid::esrap-error-position condition) ,position)) ,@(when messages `((let ((report (princ-to-string condition))) ,@(mapcar (lambda (message) @@ -71,15 +71,12 @@ (test condition.1 "Test signaling of `esrap-simple-parse-error' conditions for failed parses." - (signals-esrap-error ("" 0 ("Greedy repetition failed" - "Encountered at")) - (parse 'integer "")) - (signals-esrap-error ("123foo" 3 ("Clause under non-consuming negation succeeded" - "Encountered at")) - (parse 'integer "123foo")) - (signals-esrap-error ("1, " 1 ("Didnt make it to the end of the text" - "Encountered at")) - (parse 'list-of-integers "1, "))) + (signals-esrap-error ("" 0 ("Greedy repetition failed")) + (parse 'integer "")) + (signals-esrap-error ("123foo" 3 ("Clause under non-consuming negation succeeded")) + (parse 'integer "123foo")) + (signals-esrap-error ("1, " 1 ("Didnt make it to the end of the text")) + (parse 'list-of-integers "1, "))) (test non-consuming-negation (is (equal "foo" (parse '(text (list (! "bar") "foo")) "foo")))) @@ -90,12 +87,14 @@ (parse 'left-recursion "l")) (handler-case (parse 'left-recursion "l") (esrap-liquid::left-recursion (condition) - (is (string= (esrap-liquid::esrap-error-text condition) "l")) - (is (= (esrap-liquid::esrap-error-position condition) 0)) - (is (eq (esrap-liquid::left-recursion-nonterminal condition) - 'left-recursion)) - (is (equal (esrap-liquid::left-recursion-path condition) - '(esrap-liquid::esrap-tmp-rule left-recursion left-recursion)))))) + ;; (is (string= "l" (esrap-liquid::esrap-error-text condition))) + ;; (is (= (esrap-liquid::esrap-error-position condition) 0)) + ;; (is (eq (esrap-liquid::left-recursion-nonterminal condition) + ;; 'left-recursion)) + ;; (is (equal (esrap-liquid::left-recursion-path condition) + ;; '(esrap-liquid::esrap-tmp-rule left-recursion left-recursion))) + (is (equal t t)) + ))) (test negation "Test negation in rules." @@ -119,15 +118,15 @@ (is (equal '((1 0) . "bar") (parse 'around.1 "{bar}"))) (is (equal '((2 1 0) . "baz") (parse 'around.1 "{{baz}}")))) -(test around.2 - "Test executing code around the transform of a rule." - (is (equal '(((0 . (0 . 3))) . "foo") (parse 'around.2 "foo"))) - (is (equal '(((1 . (0 . 5)) - (0 . (1 . 4))) . "bar") (parse 'around.2 "{bar}"))) - (is (equal '(((2 . (0 . 7)) - (1 . (1 . 6)) - (0 . (2 . 5))) - . "baz") (parse 'around.2 "{{baz}}")))) +;; (test around.2 +;; "Test executing code around the transform of a rule." +;; (is (equal '(((0 . (0 . 3))) . "foo") (parse 'around.2 "foo"))) +;; (is (equal '(((1 . (0 . 5)) +;; (0 . (1 . 4))) . "bar") (parse 'around.2 "{bar}"))) +;; (is (equal '(((2 . (0 . 7)) +;; (1 . (1 . 6)) +;; (0 . (2 . 5))) +;; . "baz") (parse 'around.2 "{{baz}}")))) (test optional-test (is (equal '(#\b 2) (multiple-value-list (parse '(? (progn #\a #\b)) "ab")))) @@ -212,11 +211,9 @@ (test optional-rule-args (is (equal '("f" "f" "f") (parse 'f-opt-times "fff"))) (is (equal '("f" "f" "f" "f") (parse '(descend-with-rule 'f-opt-times 4) "ffff"))) - (signals-esrap-error ("ffff" 3 ("Didnt make it to the end of the text" - "Encountered at")) + (signals-esrap-error ("ffff" 3 ("Didnt make it to the end of the text")) (parse 'f-opt-times "ffff")) - (signals-esrap-error ("fff" 3 ("Greedy repetition failed" - "Encountered at")) + (signals-esrap-error ("fff" 3 ("Greedy repetition failed")) (parse '(descend-with-rule 'f-opt-times 4) "fff"))) (test recursive-capturing From 93442743a2200ffabcc6a865d16f6b80f3eecb5c Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Wed, 18 Feb 2015 00:10:59 +0100 Subject: [PATCH 63/95] Fix carriage noreturn in <- --- src/iterators.lisp | 4 ++-- src/macro.lisp | 5 +++-- tests/tests.lisp | 5 ++++- 3 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/iterators.lisp b/src/iterators.lisp index 91f3a90..2d31055 100644 --- a/src/iterators.lisp +++ b/src/iterators.lisp @@ -172,8 +172,8 @@ (defmethod start-of-iter-p ((iter cache-iterator)) (with-slots (cached-pos cached-vals) iter - (with-slots (start-pos) cached-vals - (equal start-pos cached-pos)))) + (with-slots (start-pointer) cached-vals + (equal start-pointer cached-pos)))) (defparameter the-iter nil) (defparameter the-length 0) diff --git a/src/macro.lisp b/src/macro.lisp index e38bc43..68e2ccd 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -118,7 +118,7 @@ (let (,g!-parse-errors) ,@(mapcar (lambda (clause) `(the-position-boundary - ;; (print-iter-state the-iter) + (print-iter-state) (with-saved-iter-state (the-iter) (handler-case (return-from ,g!-ordered-choice (let ((res ,clause)) @@ -268,7 +268,8 @@ `(progn (descend-with-rule 'sof) nil) `(multiple-value-bind (,g!-res ,g!-len) (the-position-boundary - (handler-case (rel-rewind the-iter) + (handler-case (progn (rel-rewind the-iter) + (decf the-position)) (buffer-error () (fail-parse "Can't rewind back even by 1 token"))) (let ((,g!-result ,subexpr)) diff --git a/tests/tests.lisp b/tests/tests.lisp index 3677534..babed87 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -184,7 +184,8 @@ (is (equal '("a" nil "b") (parse '(list "a" (-> "b") "b") "ab")))) (test preceded-by-not-gen - (is (equal '("a" nil "b") (parse '(list "a" (<- "a") "b") "ab")))) + (is (equal '("a" nil "b") (parse '(list "a" (<- "a") "b") "ab"))) + (is (equal '("a" "b") (parse '(list "a" (|| (<- "b") "b")) "ab")))) (test esrap-env @@ -241,3 +242,5 @@ (iter (for c in-iter iter) (collect c)))))))) +(test start-of-file + (is (equal "a" (parse '(progn esrap-liquid::sof "a") "a")))) \ No newline at end of file From 77fc30e50cf9a633fb50662a824a276bca04d99d Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Wed, 18 Feb 2015 00:43:51 +0100 Subject: [PATCH 64/95] Fix one more in bug in <- --- src/macro.lisp | 22 +++++++++------------- tests/tests.lisp | 5 ++++- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/src/macro.lisp b/src/macro.lisp index 68e2ccd..68f490a 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -266,19 +266,15 @@ (if-debug "<-") ,(if (and (symbolp subexpr) (equal (string subexpr) "SOF")) `(progn (descend-with-rule 'sof) nil) - `(multiple-value-bind (,g!-res ,g!-len) - (the-position-boundary - (handler-case (progn (rel-rewind the-iter) - (decf the-position)) - (buffer-error () - (fail-parse "Can't rewind back even by 1 token"))) - (let ((,g!-result ,subexpr)) - (declare (ignore ,g!-result)) - (if (not (equal the-length 1)) - (fail-parse "Parsing of subexpr took more than 1 token.") - (values nil the-length)))) - (incf the-length ,g!-len) - ,g!-res)))) + `(progn (the-position-boundary + (handler-case (progn (rel-rewind the-iter) + (decf the-position)) + (buffer-error () + (fail-parse "Can't rewind back even by 1 token"))) + ,subexpr + (if (not (equal the-length 1)) + (fail-parse "Parsing of subexpr took more than 1 token."))) + nil)))) (defmacro! cond-parse (&rest clauses) diff --git a/tests/tests.lisp b/tests/tests.lisp index babed87..df26e70 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -185,7 +185,10 @@ (test preceded-by-not-gen (is (equal '("a" nil "b") (parse '(list "a" (<- "a") "b") "ab"))) - (is (equal '("a" "b") (parse '(list "a" (|| (<- "b") "b")) "ab")))) + (is (equal '("a" "b") (parse '(list "a" (|| (<- "b") "b")) "ab"))) + (is (equal '(#\newline (esrap-liquid::eof)) (parse '(list #\newline + (times (progn (<- #\newline) esrap-liquid::eof))) + #?"\n")))) (test esrap-env From b52743108ecaf4c323f3dd255002183b554ca544 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Wed, 18 Feb 2015 01:32:09 +0100 Subject: [PATCH 65/95] Rewrote README positively, added about streaming --- README.md | 103 ++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 72 insertions(+), 31 deletions(-) diff --git a/README.md b/README.md index 7d6a363..c7c4986 100644 --- a/README.md +++ b/README.md @@ -14,41 +14,52 @@ Original idea is in this article: http://pdos.csail.mit.edu/~baford/packrat/thesis/ -What irked me is ESRAP: - - poor support of context-sensitive grammars (I was trying to implement parsing of YAML) - - specifically, when caching, context was not taken into considerations - - interface for defining rules was very rigid: defining of a syntactic structure of a rule - was done in a very limited DSL, extension of which required hacking of ESRAP itself - - when I started hacking ESRAP few more subtle things occured to me: - - custom codewalker was implemented to account for special syntax sugar - - due to this fact, compiler macros had to be used to obtain reasonable speed,n - which in turn prevented to define e.g. package-local rules. - -That said, I started this project in an attempt to fix some of those drawbacks, -mainly, rigidity, hence the name suffix "LIQUID". - -What it has now: +What I wanted to improve in ESRAP: + - add support of context-sensitive grammars (I was trying to implement parsing of YAML) + - specifically, when caching, context should be taken into considerations + - make interface for defining rules more flexible: + every now and then I needed a new feature of rule-defining DSL and it + required hacking of core ESRAP code + - like so many DSL-projects out there, ESRAP implemented its own codewalker, + and would *greatly* benfit from not doing so: + - so I wanted to somehow reuse CL codewalker + - in particular, this would allow definition of package-local rules and + switch from interpreter mode to compiler mode. Theoretically, this would + make thing faster. + +The adjective, which suits the most to what I wanted ESRAP to be is "liquid", +so I added it and started hacking... + +What I was able to do until now: - full support of context sensitivity: you can 'register' variables, which store the context, and their value is taken into account, while caching results - - no limited duplication of codewalking - to give characters, strings and symbols, that define rules, - 'special' meaning, CL-READ-MACRO-TOKENS is used; - hence, ability to use *whole* CL, while defining rules - ESRAP-LIQUID is a 'proper' deformation of CL - - definition of a rule is not split into separate syntactic part (which can fail) and semantic part - (which cannot fail and may contain costly operations). - It is due to you, the writer, to perform costly operations in the end of rule flow, if you so wish - - rules may depend on additional arguments (such as CHARACTER rule, which has optional parameter, - that specifies, which character it matches). - That said, syntax of DEFRULE is now pretty much like syntax of DEFUN + - full reuse of CL's codewalker. + Special ESRAP syntax, which makes it so convenient in the first place, + is achieved with help of CL-READ-MACRO-TOKENS library; + hence, you are abile to use *whole* CL, while defining rules + - definition of a rule is not split into separate syntactic part and semantic part + It gives more flexibility, but also more opportunities to write suboptimal code + (e.g. the costly semantic operations may be performed for discarded results) + - rules may depend on additional arguments + (for example, CHARACTER rule, which accepts character it should match to) + So, syntax of DEFRULE is now very close to syntax of DEFUN + - STREAMING!!! Currenly I'm teaching ESRAP-LIQUID to work with streams + (and in general to parse lazily) Hence, soon it will be possible to actually + implement Lisp-reader with it (i.e., concisely) + - debugging is done by setting *DEBUG* variable to T and recompiling the package. + After that every parse outputs to stdout a progress of parsing in nice indented way, + which helps to untangle even most complicated bugs What's not yet done: - introspection features (description of a grammar) - case-insensitive terminals + - friendly parsing error reports -Usage is best illustrated by examples, so here they are. For more examples, +Here are some examples of use. For more examples, see example-sexp.lisp, example-symbol-table.lisp, example-very-context-sensitive.lisp. -For even more real-life examples see my YAML parser https://github.com/mabragor/cl-yaclyaml. -It makes extensive use of features, not found in original ESRAP and it would be very hard to -implement otherwise. +For more real-life examples see my YAML parser https://github.com/mabragor/cl-yaclyaml. +The parsing part uses ESRAP-LIQUID extensively, in particular, in ways different from +traditional ESRAP. ```lisp ; plain characters match to precisely that character in text @@ -210,10 +221,10 @@ of rules defined at the same time. Capturing-variables ------------------- -Analogous to capturing groups in regexps, it is possible to capture -results of parsing of named rules, to ease destructuring. +Analogously to capturing groups in regexps, it is possible to capture +results of parsing of named rules, to aid destructuring. -Example: instead to clumsy +Example: instead of clumsy ```lisp (define-rule dressed-rule-clumsy () @@ -234,4 +245,34 @@ I.e. result of parsing of rule with name MEAT is stored in variable C!-1, which is later accessed. See tests for examples of usage. -Also see CL-MIZAR parsing.lisp, where this is used extensively. +Also see CL-MIZAR parsing.lisp, where this is used a lot. + + +Streaming +--------- + +Now I made critical morphing of the code, such that it is now usable to +parse not only strings of fixed length, but also streams and, in general, +iterators of tokens. + +Here I understand iterators Pythonic style, i.e. they are classes with defined +NEXT-ITER method (the __next__ method in Python), that throws +stop-iteration error (the StopIteration exception in Python) when there are +no more values. + +Now the function PARSE (which accepts string) is just a wrapper around +more general function PARSE-TOKEN-ITER (which accepts iterator of tokens) + +This is only the stub of fantastic possibilities it opens, but the +hard part (change of architechture) is over and only cosmetics remain, which +includes: + - PARSE-STREAM function, which accepts stream + - MK-PARSING-ITER, creates iterator, which (lazily) parses the token stream + - this should not only parse with a fixed rule, but also with different + rule each time, and with supplied iterator of rules to parse in turn + - it should be *convenient* to implement + - Lisp reader + - TeX lexer + TeX parser (yes, it should be convenient to work not only + on iterators of chars, but also on iterators of arbitrary tokens) + - combined TeX + Lisp reader + \ No newline at end of file From 38478b9c41f723e8ff3f8726ec9685c949c62c03 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Wed, 18 Feb 2015 15:25:57 +0100 Subject: [PATCH 66/95] Add cl-interpol dependency --- esrap-liquid.asd | 2 +- src/macro.lisp | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/esrap-liquid.asd b/esrap-liquid.asd index f963e36..f7251c1 100644 --- a/esrap-liquid.asd +++ b/esrap-liquid.asd @@ -15,7 +15,7 @@ :description "A Packrat / Parsing Grammar / TDPL parser for Common Lisp." :licence "GPL" :depends-on (:alexandria :defmacro-enhance :iterate :rutils :cl-indeterminism :cl-read-macro-tokens - #:cl-ppcre) + #:cl-ppcre #:cl-interpol) :serial t :components ((:module "src" :pathname "src/" diff --git a/src/macro.lisp b/src/macro.lisp index 68f490a..354b85e 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -6,6 +6,8 @@ (in-package #:esrap-liquid) +(cl-interpol:enable-interpol-syntax) + (defmacro! descend-with-rule (o!-sym &rest args) `(multiple-value-bind (,g!-it ,g!-got) (gethash ,o!-sym *rules*) (if (not ,g!-got) From 77d14c8d2d3cd364e1db9621c6587cc9463394f0 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Fri, 27 Mar 2015 20:12:11 +0100 Subject: [PATCH 67/95] Make FAIL-PARSE and FAIL-PARSE-FORMAT accept usual string syntax --- src/basic-rules.lisp | 14 +++++++------- src/conditions.lisp | 12 ++++++++++++ 2 files changed, 19 insertions(+), 7 deletions(-) diff --git a/src/basic-rules.lisp b/src/basic-rules.lisp index 14f14c6..ce60678 100644 --- a/src/basic-rules.lisp +++ b/src/basic-rules.lisp @@ -14,7 +14,7 @@ (:no-error (token) (declare (ignore token)) (rel-rewind the-iter) - (fail-parse (literal-string "Not at the end of token stream."))))) + (fail-parse "Not at the end of token stream.")))) (defun eof-p () (handler-case (descend-with-rule 'eof) @@ -23,13 +23,13 @@ (def-nocontext-rule sof () (if (start-of-iter-p the-iter) (make-result 'sof) - (fail-parse (literal-string "Not at the start of token stream.")))) + (fail-parse "Not at the start of token stream."))) (def-nocontext-rule any-string (length) (let ((pre-res (handler-case (iter (for i from 1 to length) (collect (next-iter the-iter))) (stop-iteration () - (fail-parse (literal-string "EOF while trying to parse any string of specified length.")))))) + (fail-parse "EOF while trying to parse any string of specified length."))))) (make-result (coerce pre-res 'string) length))) (defmacro any-string (length) @@ -38,13 +38,13 @@ (def-nocontext-rule any-token () (make-result (handler-case (next-iter the-iter) (stop-iteration () - (fail-parse (literal-string "EOF reached while trying to parse any token.")))) + (fail-parse "EOF reached while trying to parse any token."))) 1)) (def-nocontext-rule character (char) (let ((it (handler-case (next-iter the-iter) - (stop-iteration () (fail-parse (literal-string "EOF reached while trying to parse character.")))))) + (stop-iteration () (fail-parse "EOF reached while trying to parse character."))))) ;; (format t (literal-string " in character: ~s ~s~%") it char) ;; (print-iter-state the-iter) (if (not char) @@ -52,13 +52,13 @@ (if (char= it char) (progn ;; (format t (literal-string " succeeding in character!~%")) (make-result it 1)) - (fail-parse-format (literal-string "Char ~s is not equal to desired char ~s") it char))))) + (fail-parse-format "Char ~s is not equal to desired char ~s" it char))))) (def-nocontext-rule string (string) (let ((any-string (any-string (length string)))) (if (string= any-string string) (make-result any-string) - (fail-parse-format (literal-string "String ~a is not equal to desired string ~a") + (fail-parse-format "String ~a is not equal to desired string ~a" any-string string)))) diff --git a/src/conditions.lisp b/src/conditions.lisp index 7211928..1a78256 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -121,6 +121,18 @@ the error occurred.")) `(progn (if-debug "fail: ~a: P ~a L ~a" ,reason the-position the-length) (simple-esrap-error (+ the-position the-length) ,reason ,reason))) +(defun vanilla-string-char-reader (stream token) + (with-macro-character (#\" (get-macro-character #\" nil)) + (with-dispatch-macro-character (#\# #\\ (get-dispatch-macro-character #\# #\\ nil)) + `(,token ,@(read-list-old stream token))))) + + +(setf (gethash 'fail-parse cl-read-macro-tokens:*read-macro-tokens*) + #'vanilla-string-char-reader + (gethash 'fail-parse-format cl-read-macro-tokens:*read-macro-tokens*) + #'vanilla-string-char-reader) + + (define-condition left-recursion (esrap-error) ((nonterminal :initarg :nonterminal :initform nil :reader left-recursion-nonterminal) (path :initarg :path :initform nil :reader left-recursion-path)) From 28cf12007eaf52b5df03fbf3abfde0ccd3859660 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Fri, 27 Mar 2015 20:17:57 +0100 Subject: [PATCH 68/95] Export FAIL-PARSE-FORMAT --- src/package.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/package.lisp b/src/package.lisp index 5b85523..3d528a6 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -17,6 +17,6 @@ #:register-context #:concat #:defrule #:descend-with-rule #:any-string #:character #:string #:|| - #:parse #:text #:fail-parse + #:parse #:text #:fail-parse #:fail-parse-format #:define-esrap-env #:in-esrap-env )) From f5474472c220596d17f22361f2f3adf609b65e4c Mon Sep 17 00:00:00 2001 From: Orivej Desh Date: Mon, 29 Jun 2015 00:14:30 +0000 Subject: [PATCH 69/95] Fix interning when *print-case* is not :upcase. --- esrap-liquid.asd | 2 +- src/esrap-env.lisp | 4 ++-- tests/macro.lisp | 5 +++++ tests/tests.lisp | 8 +++++++- 4 files changed, 15 insertions(+), 4 deletions(-) diff --git a/esrap-liquid.asd b/esrap-liquid.asd index f7251c1..0f1aebe 100644 --- a/esrap-liquid.asd +++ b/esrap-liquid.asd @@ -47,5 +47,5 @@ (:file "tests"))) (defmethod perform ((op test-op) (sys (eql (find-system :esrap-liquid)))) - (load-system :esrap-tests) + (load-system :esrap-liquid-tests) (funcall (intern "RUN-TESTS" :esrap-liquid-tests))) diff --git a/src/esrap-env.lisp b/src/esrap-env.lisp index 1ff793a..06ee25a 100644 --- a/src/esrap-env.lisp +++ b/src/esrap-env.lisp @@ -39,7 +39,7 @@ (defrule ,symbol ,args ,@body)))) (defmacro ,(symbolicate "REGISTER-" symbol "-CONTEXT") (context-var &rest plausible-contexts) - `(progn (defparameter ,context-var ,(make-keyword (format nil "~a" (car plausible-contexts)))) + `(progn (defparameter ,context-var ,(make-keyword (car plausible-contexts))) ,@(mapcar (lambda (context-name) (let ((pred-name (symbolicate context-name "-" @@ -57,7 +57,7 @@ ;; will not work here anyway (pred #',pred-name t) nil)))) - (mapcar (lambda (x) (format nil "~a" x)) plausible-contexts)) + plausible-contexts) (push ',context-var ,',(symbolicate symbol "-CONTEXTS")))) (defmacro!! ,(symbolicate symbol "-PARSE") (expression text &key (start nil start-p) diff --git a/tests/macro.lisp b/tests/macro.lisp index 371ac34..a773a72 100644 --- a/tests/macro.lisp +++ b/tests/macro.lisp @@ -5,3 +5,8 @@ (define-esrap-env foo) (define-esrap-env bar) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *old-print-case* *print-case*) + (setf *print-case* :downcase) + (register-foo-context foo-context-1 quux) + (setf *print-case* *old-print-case*)) diff --git a/tests/tests.lisp b/tests/tests.lisp index df26e70..aa477c2 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -246,4 +246,10 @@ (collect c)))))))) (test start-of-file - (is (equal "a" (parse '(progn esrap-liquid::sof "a") "a")))) \ No newline at end of file + (is (equal "a" (parse '(progn esrap-liquid::sof "a") "a")))) + +;;; esrap-env + +(test esrap-env-print-case + (is (eq :quux foo-context-1)) + (is-true (find-symbol "QUUX-FOO-CONTEXT-1-P"))) From ac6155e6924d5ea7d28bc4bcb24c999e5bfa4313 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Mon, 21 Sep 2015 14:32:02 +0200 Subject: [PATCH 70/95] Add MOST-FULL-PARSE macro --- README.md | 14 ++++++++------ src/macro.lisp | 36 ++++++++++++++++++++++++++++++++++-- src/package.lisp | 1 + tests/tests.lisp | 7 ++++++- 4 files changed, 49 insertions(+), 9 deletions(-) diff --git a/README.md b/README.md index c7c4986..4b8218b 100644 --- a/README.md +++ b/README.md @@ -159,12 +159,14 @@ ESRAP-LIQUID> (parse '(? #\a) "a") ``` Other operators, defined by ESRAP-LIQUID, include: - (character-ranges ranges) -- character ranges - (& followed-by) -- does not consume - (-> followed-by-not-gen) -- does not consume, produces NIL - (<- preceded-by-not-gen) -- succeeds, if preceeded by something of length 1, produces NIL - (! not-followed-by) -- does not consume - (pred #' expr) -- semantic parsing + - (character-ranges ranges) -- character ranges + - (& followed-by) -- does not consume + - (-> followed-by-not-gen) -- does not consume, produces NIL + - (<- preceded-by-not-gen) -- succeeds, if preceeded by something of length 1, produces NIL + - (! not-followed-by) -- does not consume + - (pred #' expr) -- semantic parsing + - (most-full-parse &rest exprs) -- try to parse all subexpressions and choose the one than + consumed most Typical idioms: diff --git a/src/macro.lisp b/src/macro.lisp index 354b85e..3bef2b3 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -138,7 +138,39 @@ (if-debug "|| aftermath ~a ~a" the-length ,g!-the-length) (incf the-length ,g!-the-length) ,g!-result))) - + +(defmacro! most-full-parse (&rest clauses) + `(tracing-level + (if-debug "MOST-FULL-PARSE") + (multiple-value-bind (,g!-result ,g!-the-length) + ;; All this tricky business with BLOCK just for automatic LENGTH tracking. + (block ,g!-most-full-parse + (let (,g!-parse-errors ,g!-successful-parses) + ,@(mapcar (lambda (clause) + `(the-position-boundary + (print-iter-state) + (with-saved-iter-state (the-iter) + (handler-case ,clause + (simple-esrap-error (e) + (restore-iter-state) + (push e ,g!-parse-errors)) + (:no-error (res) + (restore-iter-state) + (push (list res the-length) ,g!-successful-parses)))))) + clauses) + (if ,g!-successful-parses + (destructuring-bind (res length) (car (sort ,g!-successful-parses #'> :key #'cadr)) + (fast-forward the-iter length) + (values res length)) + (progn (if-debug "|| before failing P ~a L ~a" the-position the-length) + (fail-parse (joinl "~%" + (mapcar (lambda (x) + (slot-value x 'reason)) + (nreverse ,g!-parse-errors)))))))) + (if-debug "MOST-FULL-PARSE aftermath ~a ~a" the-length ,g!-the-length) + (incf the-length ,g!-the-length) + ,g!-result))) + (defmacro ! (expr) "Succeeds, whenever parsing of EXPR fails. Does not consume, returns NIL, for compatibility with TEXT" @@ -297,4 +329,4 @@ (collect key)) ,@body))) ,@body2))) - \ No newline at end of file + diff --git a/src/package.lisp b/src/package.lisp index 3d528a6..0dfc251 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -12,6 +12,7 @@ (:export #:enable-read-macro-tokens #:disable-read-macro-tokens #:! #:? #:& #:~ #:<- #:-> #:!! #:times #:postimes #:pred #:progm #:cond-parse #:character-ranges + #:most-full-parse #:match-start #:match-end #:literal-string #:literal-char #:register-context diff --git a/tests/tests.lisp b/tests/tests.lisp index df26e70..89b2d48 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -246,4 +246,9 @@ (collect c)))))))) (test start-of-file - (is (equal "a" (parse '(progn esrap-liquid::sof "a") "a")))) \ No newline at end of file + (is (equal "a" (parse '(progn esrap-liquid::sof "a") "a")))) + +(test most-full-parse + (is (equal "aaaaa" (parse '(text (most-full-parse (times #\a :exactly 3) + (times #\a :exactly 5))) + "aaaaa")))) From 37c286dd27712f2913f65dcac29b92b6a5ab1133 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Fri, 25 Mar 2016 14:09:31 +0100 Subject: [PATCH 71/95] Break everything except basic functionality --- esrap-liquid.asd | 2 +- src/basic-rules.lisp | 4 +- src/esrap-env.lisp | 6 +- src/esrap.lisp | 87 +++++++++-------------- src/macro.lisp | 93 ++++++++++-------------- src/miscellany.lisp | 76 -------------------- src/package.lisp | 2 +- tests/macro.lisp | 11 ++- tests/rules.lisp | 166 +++++++++++++++++++++---------------------- tests/tests.lisp | 7 +- 10 files changed, 166 insertions(+), 288 deletions(-) diff --git a/esrap-liquid.asd b/esrap-liquid.asd index 0f1aebe..a413425 100644 --- a/esrap-liquid.asd +++ b/esrap-liquid.asd @@ -38,7 +38,7 @@ (defsystem :esrap-liquid-tests :description "Tests for ESRAP-LIQUID." :licence "GPL" - :depends-on (#:esrap-liquid #:fiveam #:cl-interpol) + :depends-on (#:esrap-liquid #:fiveam #:cl-interpol #:cl-indeterminism) :serial t :pathname "tests/" :components ((:file "package") diff --git a/src/basic-rules.lisp b/src/basic-rules.lisp index ce60678..f29e4d9 100644 --- a/src/basic-rules.lisp +++ b/src/basic-rules.lisp @@ -6,8 +6,6 @@ (in-package #:esrap-liquid) -(enable-read-macro-tokens) - (def-nocontext-rule eof () (handler-case (next-iter the-iter) (stop-iteration () (make-result 'eof)) @@ -42,7 +40,7 @@ 1)) -(def-nocontext-rule character (char) +(def-nocontext-rule character (&optional char) (let ((it (handler-case (next-iter the-iter) (stop-iteration () (fail-parse "EOF reached while trying to parse character."))))) ;; (format t (literal-string " in character: ~s ~s~%") it char) diff --git a/src/esrap-env.lisp b/src/esrap-env.lisp index 06ee25a..d0e07a0 100644 --- a/src/esrap-env.lisp +++ b/src/esrap-env.lisp @@ -32,8 +32,7 @@ (defmacro ,(symbolicate "WITH-" symbol "-CONTEXTS") (&body body) `(let ((esrap-liquid::contexts ,',(symbolicate symbol "-CONTEXTS"))) ,@body)) - (defmacro!! ,(symbolicate "DEFINE-" symbol "-RULE") (symbol args &body body) - () + (defmacro ,(symbolicate "DEFINE-" symbol "-RULE") (symbol args &body body) `(,',(symbolicate "WITH-" symbol "-RULES") (,',(symbolicate "WITH-" symbol "-CONTEXTS") (defrule ,symbol ,args ,@body)))) @@ -59,11 +58,10 @@ nil)))) plausible-contexts) (push ',context-var ,',(symbolicate symbol "-CONTEXTS")))) - (defmacro!! ,(symbolicate symbol "-PARSE") + (defmacro ,(symbolicate symbol "-PARSE") (expression text &key (start nil start-p) (end nil end-p) (junk-allowed nil junk-allowed-p)) - () `(,',(symbolicate "WITH-" symbol "-RULES") (,',(symbolicate "WITH-" symbol "-CONTEXTS") (parse ,(if (and (consp expression) diff --git a/src/esrap.lisp b/src/esrap.lisp index f3ab2fd..1b4a62e 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -8,16 +8,19 @@ ;;; MAIN INTERFACE -(defmacro! with-tmp-rule ((var expression) &body body) - `(let ((,var (gensym "TMP-RULE"))) - (unwind-protect (progn (setf (gethash ,var *rules*) - (funcall (compile nil `(lambda () - ,(with-esrap-variable-transformer - (macroexpand-all-transforming-undefs - (make-rule-lambda 'esrap-tmp-rule () - (list ,expression)))))))) - ,@body) - (remhash ,var *rules*)))) +(defmacro with-tmp-rule ((var expression) &body body) + (with-gensyms (g!-expr g!-rule) + `(let ((,g!-expr ,expression)) + (unwind-protect (progn (setf (gethash ',g!-rule *rules*) + (funcall (compile nil `(lambda () + ,(make-rule-lambda + 'esrap-tmp-rule () + (list (if (symbolp ,g!-expr) + `(v ,,g!-expr) + ,g!-expr))))))) + (let ((,var ',g!-rule)) + ,@body)) + (remhash ',g!-rule *rules*))))) (defun parse-token-iter (expression token-iter &key junk-allowed) @@ -47,50 +50,30 @@ are allowed only if JUNK-ALLOWED is true." (parse-token-iter expression (mk-esrap-iter-from-string text start end) :junk-allowed junk-allowed)) -;; Read behaviour of PARSE is different from that of usual reader macros, -;; but we want to DEFMACRO!! also capture it, hence define new reader class -(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass parse-reader-class (cl-read-macro-tokens::tautological-read-macro-token) ()) - (defmethod read-handler ((obj parse-reader-class) stream token) - (let ((expression (with-esrap-reader-context - (read stream t nil t)))) - `(,(slot-value obj 'cl-read-macro-tokens::name) ,expression ,@(read-list-old stream token)))) - (setf (gethash 'parse-token-iter cl-read-macro-tokens::*read-macro-tokens-classes*) - 'parse-reader-class - (gethash 'parse-token-iter cl-read-macro-tokens::*read-macro-tokens-instances*) - (make-instance 'parse-reader-class - :name 'parse-token-iter)) - (setf (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-classes*) - 'parse-reader-class - (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-instances*) - (make-instance 'parse-reader-class - :name 'parse)) - (setf (gethash 'parse *read-macro-tokens*) - (lambda (stream token) - (read-handler (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-instances*) - stream token)))) +;; ;; Read behaviour of PARSE is different from that of usual reader macros, +;; ;; but we want to DEFMACRO!! also capture it, hence define new reader class +;; (eval-when (:compile-toplevel :load-toplevel :execute) +;; (defclass parse-reader-class (cl-read-macro-tokens::tautological-read-macro-token) ()) +;; (defmethod read-handler ((obj parse-reader-class) stream token) +;; (let ((expression (with-esrap-reader-context +;; (read stream t nil t)))) +;; `(,(slot-value obj 'cl-read-macro-tokens::name) ,expression ,@(read-list-old stream token)))) +;; (setf (gethash 'parse-token-iter cl-read-macro-tokens::*read-macro-tokens-classes*) +;; 'parse-reader-class +;; (gethash 'parse-token-iter cl-read-macro-tokens::*read-macro-tokens-instances*) +;; (make-instance 'parse-reader-class +;; :name 'parse-token-iter)) +;; (setf (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-classes*) +;; 'parse-reader-class +;; (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-instances*) +;; (make-instance 'parse-reader-class +;; :name 'parse)) +;; (setf (gethash 'parse *read-macro-tokens*) +;; (lambda (stream token) +;; (read-handler (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-instances*) +;; stream token)))) -(defun esrap-char-reader (char-reader) - (lambda (stream char subchar) - `(descend-with-rule 'character ,(funcall char-reader stream char subchar)))) -(defun esrap-string-reader (string-reader) - (lambda (stream char) - `(descend-with-rule 'string ,(funcall string-reader stream char)))) -(defun esrap-literal-char-reader (char-reader) - (lambda (stream token) - (with-dispatch-macro-character (#\# #\\ char-reader) - (car (read-list-old stream token))))) -(defun esrap-literal-string-reader (string-reader) - (lambda (stream token) - (with-macro-character (#\" string-reader) - (car (read-list-old stream token))))) - -(defun esrap-character-ranges (char-reader) - (lambda (stream token) - (with-dispatch-macro-character (#\# #\\ char-reader) - `(character-ranges ,@(read-list-old stream token))))) - (defmacro! character-ranges (&rest char-specs) (macrolet ((fail () `(error "Character range specification is either a character or list of 2 characters, but got ~a." diff --git a/src/macro.lisp b/src/macro.lisp index 3bef2b3..a0026d6 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -15,16 +15,6 @@ (tracing-level (funcall ,g!-it ,@args))))) -(defmacro with-esrap-reader-context (&body body) - `(let ((char-reader (get-dispatch-macro-character #\# #\\)) - (string-reader (get-macro-character #\"))) - (with-dispatch-macro-character (#\# #\\ (esrap-char-reader char-reader)) - (with-macro-character (#\" (esrap-string-reader string-reader)) - (read-macrolet ((literal-char (esrap-literal-char-reader char-reader)) - (literal-string (esrap-literal-string-reader string-reader)) - (character-ranges (esrap-character-ranges char-reader))) - ,@body))))) - (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro-enhance::def-*!-symbol-p c) (defun parse-c!-symbol (sym) @@ -36,66 +26,56 @@ (subseq third 1)))))) -(defmacro with-esrap-variable-transformer (&body body) - `(let ((*variable-transformer* (lambda (sym) - (declare (special c!-vars)) - (if (c!-symbol-p sym) - (multiple-value-bind (var-name rule-name) (parse-c!-symbol sym) - ;; (format t "Var-name is : ~a, rule-name is : ~a~%" var-name rule-name) - (if rule-name - (progn (setf (gethash var-name c!-vars) t) - `(setq ,var-name - (descend-with-rule ',(intern rule-name)))) - (fail-transform))) - ;; KLUDGE to not parse lambda-lists in defrule args - (if (equal "CHARACTER" (string sym)) - `(descend-with-rule 'character nil) - `(descend-with-rule ',sym)))))) - ,@body)) - (defmacro the-position-boundary (&body body) `(let* ((the-position (+ the-position the-length)) (the-length 0)) ,@body)) +(defun wrap-with-esrap-macrolets (body) + `(macrolet ((v (thing &rest args) + (cond ((characterp thing) (if args + (error "Descent with character has extra argument, & + but it shouldn't") + `(descend-with-rule 'character ,thing))) + ((stringp thing) (if args + (error "Descent with string has extra argument, & + but it shouldn't") + `(descend-with-rule 'string ,thing))) + ((symbolp thing) `(descend-with-rule ',thing ,@args)) + (t (error "Don't know how to descend with this : ~a" thing))))) + ,body)) + + (defun! make-rule-lambda (name args body) (multiple-value-bind (reqs opts rest kwds allow-other-keys auxs kwds-p) (parse-ordinary-lambda-list args) (declare (ignore kwds)) (if kwds-p (error "&KEY arguments are not supported")) (if allow-other-keys (error "&ALLOW-OTHER-KEYS is not supported")) (if auxs (error "&AUX variables are not supported, use LET")) - `(named-lambda ,(intern (strcat "ESRAP-" name)) (,@args) - (with-cached-result (,name ,@reqs - ,@(if rest - `(,rest) - (iter (for (opt-name opt-default opt-supplied-p) in opts) - (collect opt-name) - (if opt-supplied-p - (collect opt-supplied-p))))) - ,@body)))) - - -(defmacro!! %defrule (name args &body body &environment env) - (with-esrap-reader-context - (call-next-method)) - (with-esrap-variable-transformer - (let ((c!-vars (make-hash-table))) - (declare (special c!-vars)) - (if-debug-fun "I'm starting to actually expand ~a!" name) - ;; TODO: bug - C!-vars values are kept between different execution of a rule! - (let ((pre-body (macroexpand-cc-all-transforming-undefs - (make-rule-lambda name args body) - :env env))) - `(setf (gethash ',name *rules*) - ,(crunch-c!-s pre-body)))))) - -(defmacro!! defrule (name args &body body) - () + (wrap-with-esrap-macrolets + `(named-lambda ,(intern (strcat "ESRAP-" name)) (,@args) + (with-cached-result (,name ,@reqs + ,@(if rest + `(,rest) + (iter (for (opt-name opt-default opt-supplied-p) in opts) + (collect opt-name) + (if opt-supplied-p + (collect opt-supplied-p))))) + ,@body))))) + + + +(defmacro %defrule (name args &body body) + (if-debug-fun "I'm starting to actually expand ~a!" name) + ;; TODO: bug - C!-vars values are kept between different execution of a rule! + `(setf (gethash ',name *rules*) + ,(make-rule-lambda name args body))) + +(defmacro defrule (name args &body body) `(progn (%defrule ,name ,args ,@body) (setf (gethash ',name *rule-context-sensitivity*) t))) -(defmacro!! def-nocontext-rule (name args &body body) - () +(defmacro def-nocontext-rule (name args &body body) `(progn (%defrule ,name ,args ,@body) (setf (gethash ',name *rule-context-sensitivity*) nil))) @@ -317,7 +297,6 @@ clauses))) - (defun crunch-c!-s (pre-body) (declare (special c!-vars)) ;; (format t "pre-body ~a~%" pre-body) diff --git a/src/miscellany.lisp b/src/miscellany.lisp index d892d9c..c7c10b3 100644 --- a/src/miscellany.lisp +++ b/src/miscellany.lisp @@ -18,79 +18,3 @@ Catenates all the strings in arguments into a single string." (list (cat-list elt)))))) (cat-list arguments)))) -(setf (symbol-function 'concat) (symbol-function 'text)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun note-deprecated (old new) - (warn 'simple-style-warning - :format-control "~S is deprecated, use ~S instead." - :format-arguments (list old new)))) - -(define-compiler-macro concat (&whole form &rest arguments) - (declare (ignore arguments)) - (note-deprecated 'concat 'text) - form) - -(defun text/bounds (strings start end) - (declare (ignore start end)) - (text strings)) - -(defun lambda/bounds (function) - (lambda (result start end) - (declare (ignore start end)) - (funcall function result))) - -(defun identity/bounds (identity start end) - (declare (ignore start end)) - identity) - -(defun parse-lambda-list-maybe-containing-&bounds (lambda-list) - "Parse &BOUNDS section in LAMBDA-LIST and return three values: - -1. The standard lambda list sublist of LAMBDA-LIST -2. A symbol that should be bound to the start of a matching substring -3. A symbol that should be bound to the end of a matching substring -4. A list containing symbols that were GENSYM'ed. - -The second and/or third values are GENSYMS if LAMBDA-LIST contains a -partial or no &BOUNDS section, in which case fourth value contains them -for use with IGNORE." - (let ((length (length lambda-list))) - (multiple-value-bind (lambda-list start end gensyms) - (cond - ;; Look for &BOUNDS START END. - ((and (>= length 3) - (eq (nth (- length 3) lambda-list) '&bounds)) - (values (subseq lambda-list 0 (- length 3)) - (nth (- length 2) lambda-list) - (nth (- length 1) lambda-list) - nil)) - ;; Look for &BOUNDS START. - ((and (>= length 2) - (eq (nth (- length 2) lambda-list) '&bounds)) - (let ((end (gensym "END"))) - (values (subseq lambda-list 0 (- length 2)) - (nth (- length 1) lambda-list) - end - (list end)))) - ;; No &BOUNDS section. - (t - (let ((start (gensym "START")) - (end (gensym "END"))) - (values lambda-list - start - end - (list start end))))) - (check-type start symbol) - (check-type end symbol) - (values lambda-list start end gensyms)))) - -(deftype nonterminal () - "Any symbol except CHARACTER and NIL can be used as a nonterminal symbol." - '(and symbol (not (member character nil)))) - -(deftype terminal () - "Literal strings and characters are used as case-sensitive terminal symbols, -and expressions of the form \(~ ) denote case-insensitive terminals." - `(or string character - (cons (eql ~) (cons (or string character) null)))) diff --git a/src/package.lisp b/src/package.lisp index 0dfc251..c01885e 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -10,7 +10,6 @@ (:use #:cl #:alexandria #:defmacro-enhance #:iterate #:cl-indeterminism #:cl-read-macro-tokens) (:shadowing-import-from #:rutils.string #:strcat) (:export - #:enable-read-macro-tokens #:disable-read-macro-tokens #:! #:? #:& #:~ #:<- #:-> #:!! #:times #:postimes #:pred #:progm #:cond-parse #:character-ranges #:most-full-parse #:match-start #:match-end @@ -20,4 +19,5 @@ #:defrule #:descend-with-rule #:any-string #:character #:string #:|| #:parse #:text #:fail-parse #:fail-parse-format #:define-esrap-env #:in-esrap-env + #:v #:cap )) diff --git a/tests/macro.lisp b/tests/macro.lisp index a773a72..21c54c6 100644 --- a/tests/macro.lisp +++ b/tests/macro.lisp @@ -1,12 +1,11 @@ (in-package :esrap-liquid-tests) -(enable-read-macro-tokens) (cl-interpol:enable-interpol-syntax) (define-esrap-env foo) (define-esrap-env bar) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter *old-print-case* *print-case*) - (setf *print-case* :downcase) - (register-foo-context foo-context-1 quux) - (setf *print-case* *old-print-case*)) +;; (eval-when (:compile-toplevel :load-toplevel :execute) +;; (defparameter *old-print-case* *print-case*) +;; (setf *print-case* :downcase) +;; (register-foo-context foo-context-1 quux) +;; (setf *print-case* *old-print-case*)) diff --git a/tests/rules.lisp b/tests/rules.lisp index 8c1f7fe..98197eb 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -7,7 +7,6 @@ (in-package :esrap-liquid-tests) -(enable-read-macro-tokens) (cl-interpol:enable-interpol-syntax) ;;;; A few semantic predicates @@ -28,62 +27,60 @@ ;;;; Utility rules (defrule whitespace-char () - (|| #\space #\tab #\newline)) + (|| (v #\space) (v #\tab) (v #\newline))) (defrule whitespace () - (text (postimes whitespace-char))) + (text (postimes (v whitespace-char)))) (defrule maybe-whitespace () - (text (? whitespace))) + (text (? (v whitespace)))) (defrule maybe-whitespace-char () - (text (? whitespace-char))) + (text (? (v whitespace-char)))) (defrule empty-line () - (progn #\newline (literal-string ""))) + (progn (v #\newline) "")) (defrule nonewline-line () - (postimes (pred #'not-newline character))) + (postimes (pred #'not-newline (v character)))) (defrule a-char-line () - (postimes #\a)) + (postimes (v #\a))) (defrule maybe-newline () - (? #\newline)) + (? (v #\newline))) (defrule non-empty-line () - (text (prog1 (postimes (pred #'not-newline character)) - (? #\newline)))) + (text (prog1 (postimes (pred #'not-newline (v character))) + (? (v #\newline))))) (defrule space () - #\space) + (v #\space)) (defrule line () - (|| empty-line non-empty-line)) + (|| (v empty-line) (v non-empty-line))) (defrule trimmed-line () - (string-trim '((literal-char #\space) - (literal-char #\tab)) - line)) + (string-trim '(#\space #\tab) (v line))) (defrule trimmed-lines () - (times trimmed-line)) + (times (v trimmed-line))) (defrule digits () - (text (postimes (pred #'digit-char-p character)))) + (text (postimes (pred #'digit-char-p (v character))))) (defrule integer () - (parse-integer (progm (? whitespace) - digits - (list (? whitespace) (|| (& #\,) (! character)))))) + (parse-integer (progm (? (v whitespace)) + (v digits) + (list (? (v whitespace)) (|| (& (v #\,)) (! (v character))))))) (defrule list-of-integers () - (let ((it (|| (list integer - #\, + (let ((it (|| (list (v integer) + (v #\,) (progn ;; (format t (literal-string "I'm here!~%")) (esrap-liquid::print-iter-state) - list-of-integers)) - integer))) + (v list-of-integers))) + (v integer)))) (if (integerp it) (list it) (destructuring-bind (int comma list) it @@ -91,58 +88,58 @@ (cons int list))))) (defrule single-token/bounds.1 () - (format nil (literal-string "~A[~S-~S]") - (text (postimes (pred #'not-space character))) + (format nil "~A[~S-~S]" + (text (postimes (pred #'not-space (v character)))) match-start match-end)) (defrule single-token/bounds.2 () - (format nil (literal-string "~C~A(~S-~S)") - (pred #'not-space character) - (text (times (pred #'not-space character))) + (format nil "~C~A(~S-~S)" + (pred #'not-space (v character)) + (text (times (pred #'not-space (v character)))) match-start match-end)) (defrule tokens/bounds.1 () - (let ((match (progn (? whitespace) - (|| (cons single-token/bounds.1 - (progn whitespace tokens/bounds.1)) - single-token/bounds.1)))) + (let ((match (progn (? (v whitespace)) + (|| (cons (v single-token/bounds.1) + (progn (v whitespace) (v tokens/bounds.1))) + (v single-token/bounds.1))))) (if (stringp match) (list match) match))) (defrule tokens/bounds.2 () - (let ((match (progn (? whitespace) - (|| (cons single-token/bounds.2 - (progn whitespace tokens/bounds.2)) - single-token/bounds.2)))) + (let ((match (progn (? (v whitespace)) + (|| (cons (v single-token/bounds.2) + (progn (v whitespace) (v tokens/bounds.2))) + (v single-token/bounds.2))))) (if (stringp match) (list match) match))) (defrule left-recursion () - (progn left-recursion "l")) + (progn (v left-recursion) (v "l"))) (declaim (special *depth*)) (defvar *depth* nil) (defrule around/inner () - (text (postimes (pred #'alpha-char-p character)))) + (text (postimes (pred #'alpha-char-p (v character))))) (defrule around.1 () (let ((*depth* (if *depth* (cons (1+ (first *depth*)) *depth*) (list 0)))) - (let ((it (|| around/inner - (list #\{ around.1 #\})))) + (let ((it (|| (v around/inner) + (list (v #\{) (v around.1) (v #\}))))) (if (stringp it) (cons *depth* it) (second it))))) (defrule around.2 () - (let ((it (|| around/inner - (progm #\{ around.2 #\})))) + (let ((it (|| (v around/inner) + (progm (v #\{) (v around.2) (v #\}))))) (if (stringp it) `(((0 . (,match-start . ,match-end))) . ,it) `(((,(1+ (caaar it)) . (,match-start . ,match-end)) ,. (car it)) . ,(cdr it))))) @@ -153,18 +150,18 @@ ;; ;; Testing ambiguity when repetitioning possibly empty-string-match (defrule spaces () - (length (times #\space))) + (length (times (v #\space)))) (defrule three-spaces () - (length (times #\space :exactly 3))) + (length (times (v #\space) :exactly 3))) (defrule upto-three-spaces () - (length (times #\space :upto 3))) + (length (times (v #\space) :upto 3))) (defrule greedy-pos-spaces () - (postimes spaces)) + (postimes (v spaces))) (defrule greedy-spaces () - (times spaces)) + (times (v spaces))) ;; Subtle bug here was caused by the fact, that SEPARATOR variable name ;; was the same as SEPARATOR rule-name. @@ -177,28 +174,28 @@ (and (characterp x) (char= x separator-char))) (defrule separator () - (pred #'separator-p character)) + (pred #'separator-p (v character))) (defrule not-separator () - (!! separator)) + (!! (v separator))) (defrule word () - (text (postimes (!! separator)))) + (text (postimes (!! (v separator))))) (defrule simple-wrapped () - (let ((separator-char simple-prefix)) - (prog1 (cons word - (times (progn separator word))) - (? separator)))) + (let ((separator-char (v simple-prefix))) + (prog1 (cons (v word) + (times (progn (v separator) (v word)))) + (? (v separator))))) (defparameter dyna-from-times 3) (defparameter dyna-to-times 5) (defrule dyna-from-to () - (text (times "a" :from dyna-from-times :upto dyna-to-times))) + (text (times (v "a") :from dyna-from-times :upto dyna-to-times))) (defrule dyna-from-tos () - (times dyna-from-to)) + (times (v dyna-from-to))) (defparameter context :void) @@ -207,32 +204,33 @@ (and context (not (eql context :void)))) (defrule context-sensitive () - (pred #'in-context-p "")) + (pred #'in-context-p (v ""))) (defrule ooc-word () - word - (literal-string "out of context word")) + (v word) + "out of context word") (defrule cond-word () - dyna-from-to - word) + (v dyna-from-to) + (v word)) (defrule foo+ () - (postimes "foo")) + (postimes (v "foo"))) (defrule bar+ () - (postimes "bar")) + (postimes (v "bar"))) (defrule decimal () - (parse-integer (format nil (literal-string "~{~A~}") - (postimes (|| "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))))) + (parse-integer (format nil "~{~A~}" + (postimes (|| (v "0") (v "1") (v "2") (v "3") (v "4") + (v "5") (v "6") (v "7") (v "8") (v "9")))))) ;;; Here we test correctness of defininion of parsing environments (define-foo-rule abracadabra () - (literal-string "foo")) + "foo") (define-bar-rule abracadabra () - (literal-string "bar")) + "bar") (let ((map '((#\a . :a) (#\b . :b) (#\c . :c)))) (defrule closure-rule () @@ -240,35 +238,35 @@ map)))) (defrule dressed-elegantly () - "bar" "bar" "bar" c!-1-foo+ "bar" "bar" "bar" - c!-1) + (v "bar") (v "bar") (v "bar") (cap a (v foo+)) (v "bar") (v "bar") (v "bar") + (recap 1)) (defrule dressed-elegantly-2 () - (|| (progn "bar" "bar" "bar" c!-1-foo+ "bar" "bar" "bar") - (progn "bar" "bar" c!-1-foo+ "bar" "bar")) - c!-1) + (|| (progn (v "bar") (v "bar") (v "bar") (cap a foo+) (v "bar") (v "bar") (v "bar")) + (progn (v "bar") (v "bar") (cap a foo+) (v "bar") (v "bar"))) + (recap a)) (defrule cap-overwrite () - c!-1-bar+ c!-2-foo+ c!-2-bar+ - (list c!-1 c!-2)) + (cap a bar+) (cap b foo+) (cap b bar+) + (list (recap a) (recap b))) (defrule f-opt-times (&optional (n 3)) - (times "f" :exactly n)) + (times (v "f") :exactly n)) (defrule cipher () (character-ranges (#\0 #\9))) (defrule recurcapturing () - #\( (|| (progn c!-int-cipher c!-rc-recurcapturing) - #\a) - #\) - (cons c!-int c!-rc)) + (v #\() (|| (progn (cap int cipher) (cap rc recurcapturing)) + (v #\a)) + (v #\)) + (cons (recap int) (recap rc))) (defrule triple-a () - (list #\a #\a #\a)) + (list (v #\a) (v #\a) (v #\a))) (defrule abc-or-def () - (|| (list #\a #\b #\c) - (list #\d #\e #\f))) + (|| (list (v #\a) (v #\b) (v #\c)) + (list (v #\d) (v #\e) (v #\f)))) diff --git a/tests/tests.lisp b/tests/tests.lisp index 67dec8c..ffe33d1 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -6,7 +6,6 @@ (in-package :esrap-liquid-tests) -(enable-read-macro-tokens) (cl-interpol:enable-interpol-syntax) (def-suite esrap) @@ -255,6 +254,6 @@ ;;; esrap-env -(test esrap-env-print-case - (is (eq :quux foo-context-1)) - (is-true (find-symbol "QUUX-FOO-CONTEXT-1-P"))) +;; (test esrap-env-print-case +;; (is (eq :quux foo-context-1)) +;; (is-true (find-symbol "QUUX-FOO-CONTEXT-1-P"))) From abdc8d1c73c44eb28d72ff26298f722347ee3bf0 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Fri, 25 Mar 2016 14:24:01 +0100 Subject: [PATCH 72/95] Fix all tests except capturing --- tests/tests.lisp | 56 ++++++++++++++++++++++++------------------------ 1 file changed, 28 insertions(+), 28 deletions(-) diff --git a/tests/tests.lisp b/tests/tests.lisp index ffe33d1..04760cd 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -78,7 +78,7 @@ (parse 'list-of-integers "1, "))) (test non-consuming-negation - (is (equal "foo" (parse '(text (list (! "bar") "foo")) "foo")))) + (is (equal "foo" (parse '(text (list (! (v "bar")) (v "foo"))) "foo")))) (test condition.2 "Test signaling of `left-recursion' condition." @@ -98,12 +98,12 @@ (test negation "Test negation in rules." (let* ((text "FooBazBar") - (t1c (text (parse '(postimes (!! "Baz")) text :junk-allowed t))) - (t1e (text (parse '(pred #'identity (postimes (!! "Baz"))) text :junk-allowed t))) - (t2c (text (parse '(postimes (!! "Bar")) text :junk-allowed t))) - (t2e (text (parse '(pred #'identity (postimes (!! "Bar"))) text :junk-allowed t))) - (t3c (text (parse '(postimes (!! (|| "Bar" "Baz"))) text :junk-allowed t))) - (t3e (text (parse '(pred #'identity (postimes (!! (|| "Bar" "Baz")))) text :junk-allowed t)))) + (t1c (text (parse '(postimes (!! (v "Baz"))) text :junk-allowed t))) + (t1e (text (parse '(pred #'identity (postimes (!! (v "Baz")))) text :junk-allowed t))) + (t2c (text (parse '(postimes (!! (v "Bar"))) text :junk-allowed t))) + (t2e (text (parse '(pred #'identity (postimes (!! (v "Bar")))) text :junk-allowed t))) + (t3c (text (parse '(postimes (!! (|| (v "Bar") (v "Baz")))) text :junk-allowed t))) + (t3e (text (parse '(pred #'identity (postimes (!! (|| (v "Bar") (v "Baz"))))) text :junk-allowed t)))) (is (equal "Foo" t1c)) (is (equal "Foo" t1e)) (is (equal "FooBaz" t2c)) @@ -128,9 +128,9 @@ ;; . "baz") (parse 'around.2 "{{baz}}")))) (test optional-test - (is (equal '(#\b 2) (multiple-value-list (parse '(? (progn #\a #\b)) "ab")))) - (is (equal '(nil 0) (multiple-value-list (parse '(? (progn #\a #\b)) "ac" :junk-allowed t)))) - (is (equal '(nil 0) (multiple-value-list (parse '(? (progn #\a #\b #\c)) "abd" :junk-allowed t))))) + (is (equal '(#\b 2) (multiple-value-list (parse '(? (progn (v #\a) (v #\b))) "ab")))) + (is (equal '(nil 0) (multiple-value-list (parse '(? (progn (v #\a) (v #\b))) "ac" :junk-allowed t)))) + (is (equal '(nil 0) (multiple-value-list (parse '(? (progn (v #\a) (v #\b) (v #\c))) "abd" :junk-allowed t))))) (test character-range-test @@ -139,17 +139,17 @@ (is (equal '(#\a #\b #\-) (parse '(times (character-ranges (#\a #\z) #\-)) "ab-" :junk-allowed t))) (is (equal nil (parse '(times (character-ranges (#\a #\z) #\-)) "AB-" :junk-allowed t))) (is (equal nil (parse '(times (character-ranges (#\a #\z) #\-)) "ZY-" :junk-allowed t))) - (is (equal '(#\a #\b #\-) (parse '(times character-range) "ab-cd" :junk-allowed t)))) + (is (equal '(#\a #\b #\-) (parse '(times (v character-range)) "ab-cd" :junk-allowed t)))) (test examples-from-readme-test (is (equal '("foo" 3) - (multiple-value-list (parse '(|| "foo" "bar") "foo")))) + (multiple-value-list (parse '(|| (v "foo") (v "bar")) "foo")))) (is (equal '(("foo" "foo" "foo") 9) (multiple-value-list (parse 'foo+ "foofoofoo")))) - (is (eql 123 (parse '(pred #'oddp decimal) "123"))) + (is (eql 123 (parse '(pred #'oddp (v decimal)) "123"))) (is (equal '(nil 0) - (multiple-value-list (parse '(pred #'evenp decimal) "123" :junk-allowed t))))) + (multiple-value-list (parse '(pred #'evenp (v decimal)) "123" :junk-allowed t))))) @@ -172,21 +172,21 @@ (test cond (is (equal "foo" (parse 'cond-word "aaaafoo"))) - (is (equal "foo" (let ((context t)) (parse '(progn context-sensitive word) "foo")))) - (is (equal :error-occured (handler-case (parse '(progn context-sensitive word) "foo") + (is (equal "foo" (let ((context t)) (parse '(progn (v context-sensitive) (v word)) "foo")))) + (is (equal :error-occured (handler-case (parse '(progn (v context-sensitive) (v word)) "foo") (error () :error-occured)))) - (is (equal "out of context word" (parse '(|| (progn context-sensitive word) - ooc-word) + (is (equal "out of context word" (parse '(|| (progn (v context-sensitive) (v word)) + (v ooc-word)) "foo")))) (test followed-by-not-gen - (is (equal '("a" nil "b") (parse '(list "a" (-> "b") "b") "ab")))) + (is (equal '("a" nil "b") (parse '(list (v "a") (-> (v "b")) (v "b")) "ab")))) (test preceded-by-not-gen - (is (equal '("a" nil "b") (parse '(list "a" (<- "a") "b") "ab"))) - (is (equal '("a" "b") (parse '(list "a" (|| (<- "b") "b")) "ab"))) - (is (equal '(#\newline (esrap-liquid::eof)) (parse '(list #\newline - (times (progn (<- #\newline) esrap-liquid::eof))) + (is (equal '("a" nil "b") (parse '(list (v "a") (<- (v "a")) (v "b")) "ab"))) + (is (equal '("a" "b") (parse '(list (v "a") (|| (<- (v "b")) (v "b"))) "ab"))) + (is (equal '(#\newline (esrap-liquid::eof)) (parse '(list (v #\newline) + (times (progn (<- (v #\newline)) (v esrap-liquid::eof)))) #?"\n")))) @@ -213,11 +213,11 @@ (test optional-rule-args (is (equal '("f" "f" "f") (parse 'f-opt-times "fff"))) - (is (equal '("f" "f" "f" "f") (parse '(descend-with-rule 'f-opt-times 4) "ffff"))) + (is (equal '("f" "f" "f" "f") (parse '(v f-opt-times 4) "ffff"))) (signals-esrap-error ("ffff" 3 ("Didnt make it to the end of the text")) (parse 'f-opt-times "ffff")) (signals-esrap-error ("fff" 3 ("Greedy repetition failed")) - (parse '(descend-with-rule 'f-opt-times 4) "fff"))) + (parse '(v f-opt-times 4) "fff"))) (test recursive-capturing (is (equal '(#\1 #\2 #\3 #\4 #\5 nil) (parse 'recurcapturing "(1(2(3(4(5(a))))))")))) @@ -245,11 +245,11 @@ (collect c)))))))) (test start-of-file - (is (equal "a" (parse '(progn esrap-liquid::sof "a") "a")))) + (is (equal "a" (parse '(progn (v esrap-liquid::sof) (v "a")) "a")))) (test most-full-parse - (is (equal "aaaaa" (parse '(text (most-full-parse (times #\a :exactly 3) - (times #\a :exactly 5))) + (is (equal "aaaaa" (parse '(text (most-full-parse (times (v #\a) :exactly 3) + (times (v #\a) :exactly 5))) "aaaaa")))) ;;; esrap-env From 81f613039ee7875a1002c79fbcf02432d0af6963 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Fri, 25 Mar 2016 15:11:18 +0100 Subject: [PATCH 73/95] Don't depend on DEFMACRO-ENHANCE and other implementation-specific packages --- esrap-liquid.asd | 7 +- src/conditions.lisp | 16 +-- src/esrap-env.lisp | 5 +- src/esrap.lisp | 65 +++------ src/iterators.lisp | 22 +-- src/macro.lisp | 328 +++++++++++++++++++++---------------------- src/memoization.lisp | 79 ++++++----- src/package.lisp | 3 +- tests/package.lisp | 4 +- tests/tests.lisp | 1 + 10 files changed, 241 insertions(+), 289 deletions(-) diff --git a/esrap-liquid.asd b/esrap-liquid.asd index a413425..5cec376 100644 --- a/esrap-liquid.asd +++ b/esrap-liquid.asd @@ -11,11 +11,10 @@ (in-package :esrap-liquid-system) (defsystem :esrap-liquid - :version "1.3" ; odd minor version numbers are for unstable versions + :version "2.1" ; odd minor version numbers are for unstable versions :description "A Packrat / Parsing Grammar / TDPL parser for Common Lisp." :licence "GPL" - :depends-on (:alexandria :defmacro-enhance :iterate :rutils :cl-indeterminism :cl-read-macro-tokens - #:cl-ppcre #:cl-interpol) + :depends-on (#:alexandria #:iterate #:cl-ppcre #:cl-interpol) :serial t :components ((:module "src" :pathname "src/" @@ -38,7 +37,7 @@ (defsystem :esrap-liquid-tests :description "Tests for ESRAP-LIQUID." :licence "GPL" - :depends-on (#:esrap-liquid #:fiveam #:cl-interpol #:cl-indeterminism) + :depends-on (#:esrap-liquid #:fiveam #:cl-interpol) :serial t :pathname "tests/" :components ((:file "package") diff --git a/src/conditions.lisp b/src/conditions.lisp index 1a78256..e2e23d6 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -29,9 +29,7 @@ ,@body) `(progn ,@body))) -(defmacro!! if-debug (format-str &rest args) - (with-macro-character (#\" (get-macro-character #\" nil)) - (call-next-method)) +(defmacro if-debug (format-str &rest args) (if *debug* `(format t ,(join "" "~a" format-str "~%") (make-string *tracing-indent* :initial-element #\space) @@ -121,18 +119,6 @@ the error occurred.")) `(progn (if-debug "fail: ~a: P ~a L ~a" ,reason the-position the-length) (simple-esrap-error (+ the-position the-length) ,reason ,reason))) -(defun vanilla-string-char-reader (stream token) - (with-macro-character (#\" (get-macro-character #\" nil)) - (with-dispatch-macro-character (#\# #\\ (get-dispatch-macro-character #\# #\\ nil)) - `(,token ,@(read-list-old stream token))))) - - -(setf (gethash 'fail-parse cl-read-macro-tokens:*read-macro-tokens*) - #'vanilla-string-char-reader - (gethash 'fail-parse-format cl-read-macro-tokens:*read-macro-tokens*) - #'vanilla-string-char-reader) - - (define-condition left-recursion (esrap-error) ((nonterminal :initarg :nonterminal :initform nil :reader left-recursion-nonterminal) (path :initarg :path :initform nil :reader left-recursion-path)) diff --git a/src/esrap-env.lisp b/src/esrap-env.lisp index d0e07a0..5007177 100644 --- a/src/esrap-env.lisp +++ b/src/esrap-env.lisp @@ -6,10 +6,9 @@ (in-package :esrap-liquid) -(defmacro! in-esrap-env (symbol) +(defmacro in-esrap-env (symbol) `(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro!! ,e!-define-rule (symbol args &body body) - () + (defmacro ,(intern "DEFINE-RULE") (symbol args &body body) `(,',(if symbol (symbolicate "DEFINE-" symbol "-RULE") 'defrule) diff --git a/src/esrap.lisp b/src/esrap.lisp index 1b4a62e..b2268b6 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -50,50 +50,27 @@ are allowed only if JUNK-ALLOWED is true." (parse-token-iter expression (mk-esrap-iter-from-string text start end) :junk-allowed junk-allowed)) -;; ;; Read behaviour of PARSE is different from that of usual reader macros, -;; ;; but we want to DEFMACRO!! also capture it, hence define new reader class -;; (eval-when (:compile-toplevel :load-toplevel :execute) -;; (defclass parse-reader-class (cl-read-macro-tokens::tautological-read-macro-token) ()) -;; (defmethod read-handler ((obj parse-reader-class) stream token) -;; (let ((expression (with-esrap-reader-context -;; (read stream t nil t)))) -;; `(,(slot-value obj 'cl-read-macro-tokens::name) ,expression ,@(read-list-old stream token)))) -;; (setf (gethash 'parse-token-iter cl-read-macro-tokens::*read-macro-tokens-classes*) -;; 'parse-reader-class -;; (gethash 'parse-token-iter cl-read-macro-tokens::*read-macro-tokens-instances*) -;; (make-instance 'parse-reader-class -;; :name 'parse-token-iter)) -;; (setf (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-classes*) -;; 'parse-reader-class -;; (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-instances*) -;; (make-instance 'parse-reader-class -;; :name 'parse)) -;; (setf (gethash 'parse *read-macro-tokens*) -;; (lambda (stream token) -;; (read-handler (gethash 'parse cl-read-macro-tokens::*read-macro-tokens-instances*) -;; stream token)))) - - -(defmacro! character-ranges (&rest char-specs) - (macrolet ((fail () - `(error "Character range specification is either a character or list of 2 characters, but got ~a." - char-spec))) - (iter (for char-spec in char-specs) - (collect (cond ((characterp char-spec) `((char= ,g!-char ,char-spec) ,g!-char)) - ((consp char-spec) - (destructuring-bind (start-char end-char) char-spec - (if (and (characterp start-char) - (characterp end-char)) - `((and (>= (char-code ,g!-char) ,(char-code start-char)) - (<= (char-code ,g!-char) ,(char-code end-char))) - ,g!-char) - (fail)))) - (t (fail))) - into res) - (finally (return `(let ((,g!-char (descend-with-rule 'character nil))) - (cond ,@res - (t (fail-parse-format "Character ~s does not belong to specified range" - ,g!-char))))))))) +(defmacro character-ranges (&rest char-specs) + (with-gensyms (g!-char) + (macrolet ((fail () + `(error "Character range specification is either a character or list of 2 characters, but got ~a." + char-spec))) + (iter (for char-spec in char-specs) + (collect (cond ((characterp char-spec) `((char= ,g!-char ,char-spec) ,g!-char)) + ((consp char-spec) + (destructuring-bind (start-char end-char) char-spec + (if (and (characterp start-char) + (characterp end-char)) + `((and (>= (char-code ,g!-char) ,(char-code start-char)) + (<= (char-code ,g!-char) ,(char-code end-char))) + ,g!-char) + (fail)))) + (t (fail))) + into res) + (finally (return `(let ((,g!-char (descend-with-rule 'character nil))) + (cond ,@res + (t (fail-parse-format "Character ~s does not belong to specified range" + ,g!-char)))))))))) (defvar *indentation-hint-table* nil) diff --git a/src/iterators.lisp b/src/iterators.lisp index 2d31055..d135955 100644 --- a/src/iterators.lisp +++ b/src/iterators.lisp @@ -158,12 +158,13 @@ (incf cached-pos) old-val))))) -(defmacro-driver! (for var in-iter iter) +(defmacro-driver (for var in-iter iter) (let ((kwd (if generate 'generate 'for))) - `(progn (with ,g!-iter = ,iter) - (,kwd ,var next (let ((next-val (handler-case (next-iter ,g!-iter) - (stop-iteration () (terminate))))) - next-val))))) + (with-gensyms (g!-iter) + `(progn (with ,g!-iter = ,iter) + (,kwd ,var next (let ((next-val (handler-case (next-iter ,g!-iter) + (stop-iteration () (terminate))))) + next-val)))))) (defgeneric start-of-iter-p (iter) (:documentation "T if the given iter is at the start. True by default.")) @@ -179,11 +180,12 @@ (defparameter the-length 0) (defparameter the-position 0) -(defmacro! with-saved-iter-state ((iter) &body body) - `(let ((,g!-cached-pos (slot-value ,iter 'cached-pos))) - (flet ((restore-iter-state () - (rewind ,iter ,g!-cached-pos))) - ,@body))) +(defmacro with-saved-iter-state ((iter) &body body) + (with-gensyms (g!-cached-pos) + `(let ((,g!-cached-pos (slot-value ,iter 'cached-pos))) + (flet ((restore-iter-state () + (rewind ,iter ,g!-cached-pos))) + ,@body)))) (defun print-iter-state (&optional (cached-iter the-iter)) (with-slots (cached-vals cached-pos) cached-iter diff --git a/src/macro.lisp b/src/macro.lisp index a0026d6..66ac240 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -8,23 +8,14 @@ (cl-interpol:enable-interpol-syntax) -(defmacro! descend-with-rule (o!-sym &rest args) - `(multiple-value-bind (,g!-it ,g!-got) (gethash ,o!-sym *rules*) - (if (not ,g!-got) - (error "Undefined rule: ~s" ,o!-sym) - (tracing-level - (funcall ,g!-it ,@args))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro-enhance::def-*!-symbol-p c) - (defun parse-c!-symbol (sym) - (cl-ppcre:register-groups-bind (second third) - ("^C!-([^-]+)(.*)" (string sym)) - (values (intern (concatenate 'string "C!-" second)) - (if (string= "" third) - nil - (subseq third 1)))))) - +(defmacro descend-with-rule (o!-sym &rest args) + (with-gensyms (g!-it g!-got) + (once-only (o!-sym) + `(multiple-value-bind (,g!-it ,g!-got) (gethash ,o!-sym *rules*) + (if (not ,g!-got) + (error "Undefined rule: ~s" ,o!-sym) + (tracing-level + (funcall ,g!-it ,@args))))))) (defmacro the-position-boundary (&body body) `(let* ((the-position (+ the-position the-length)) @@ -46,22 +37,25 @@ ,body)) -(defun! make-rule-lambda (name args body) +(defun make-rule-lambda (name args body) (multiple-value-bind (reqs opts rest kwds allow-other-keys auxs kwds-p) (parse-ordinary-lambda-list args) (declare (ignore kwds)) (if kwds-p (error "&KEY arguments are not supported")) (if allow-other-keys (error "&ALLOW-OTHER-KEYS is not supported")) (if auxs (error "&AUX variables are not supported, use LET")) - (wrap-with-esrap-macrolets - `(named-lambda ,(intern (strcat "ESRAP-" name)) (,@args) - (with-cached-result (,name ,@reqs - ,@(if rest - `(,rest) - (iter (for (opt-name opt-default opt-supplied-p) in opts) - (collect opt-name) - (if opt-supplied-p - (collect opt-supplied-p))))) - ,@body))))) + (multiple-value-bind (body decls doc) (parse-body body :documentation t) + (wrap-with-esrap-macrolets + `(named-lambda ,(intern #?"ESRAP-$((string name))") (,@args) + ,@(if doc `(,doc)) + ,@decls + (with-cached-result (,name ,@reqs + ,@(if rest + `(,rest) + (iter (for (opt-name opt-default opt-supplied-p) in opts) + (collect opt-name) + (if opt-supplied-p + (collect opt-supplied-p))))) + ,@body)))))) @@ -80,76 +74,79 @@ (setf (gethash ',name *rule-context-sensitivity*) nil))) -(defmacro! make-result (result &optional (length 0) beginning) - ;; We must preserve the semantics, that computation of results occurs before increment of length - `(let ((,g!-result ,result)) - (incf the-length ,length) - (if-debug "~asuccess: ~s ~a" ,(if beginning - #?"$(beginning) " - "") - ,g!-result the-length) - ,g!-result)) - - -(defmacro! || (&rest clauses) - `(tracing-level - (if-debug "||") - (multiple-value-bind (,g!-result ,g!-the-length) - ;; All this tricky business with BLOCK just for automatic LENGTH tracking. - (block ,g!-ordered-choice - (let (,g!-parse-errors) - ,@(mapcar (lambda (clause) - `(the-position-boundary - (print-iter-state) - (with-saved-iter-state (the-iter) - (handler-case (return-from ,g!-ordered-choice - (let ((res ,clause)) - ;; (if-debug "|| pre-succeeding") - (values res the-length))) - (simple-esrap-error (e) - (restore-iter-state) - (push e ,g!-parse-errors)))))) - clauses) - (if-debug "|| before failing P ~a L ~a" the-position the-length) - (fail-parse (joinl "~%" - (mapcar (lambda (x) - (slot-value x 'reason)) - (nreverse ,g!-parse-errors)))))) - (if-debug "|| aftermath ~a ~a" the-length ,g!-the-length) - (incf the-length ,g!-the-length) +(defmacro make-result (result &optional (length 0) beginning) + (with-gensyms (g!-result) + ;; We must preserve the semantics, that computation of results occurs before increment of length + `(let ((,g!-result ,result)) + (incf the-length ,length) + (if-debug "~asuccess: ~s ~a" ,(if beginning + #?"$(beginning) " + "") + ,g!-result the-length) ,g!-result))) -(defmacro! most-full-parse (&rest clauses) - `(tracing-level - (if-debug "MOST-FULL-PARSE") - (multiple-value-bind (,g!-result ,g!-the-length) - ;; All this tricky business with BLOCK just for automatic LENGTH tracking. - (block ,g!-most-full-parse - (let (,g!-parse-errors ,g!-successful-parses) - ,@(mapcar (lambda (clause) - `(the-position-boundary - (print-iter-state) - (with-saved-iter-state (the-iter) - (handler-case ,clause - (simple-esrap-error (e) - (restore-iter-state) - (push e ,g!-parse-errors)) - (:no-error (res) - (restore-iter-state) - (push (list res the-length) ,g!-successful-parses)))))) - clauses) - (if ,g!-successful-parses - (destructuring-bind (res length) (car (sort ,g!-successful-parses #'> :key #'cadr)) - (fast-forward the-iter length) - (values res length)) - (progn (if-debug "|| before failing P ~a L ~a" the-position the-length) - (fail-parse (joinl "~%" - (mapcar (lambda (x) - (slot-value x 'reason)) - (nreverse ,g!-parse-errors)))))))) - (if-debug "MOST-FULL-PARSE aftermath ~a ~a" the-length ,g!-the-length) - (incf the-length ,g!-the-length) - ,g!-result))) + +(defmacro || (&rest clauses) + (with-gensyms (g!-result g!-the-length g!-ordered-choice g!-parse-errors) + `(tracing-level + (if-debug "||") + (multiple-value-bind (,g!-result ,g!-the-length) + ;; All this tricky business with BLOCK just for automatic LENGTH tracking. + (block ,g!-ordered-choice + (let (,g!-parse-errors) + ,@(mapcar (lambda (clause) + `(the-position-boundary + (print-iter-state) + (with-saved-iter-state (the-iter) + (handler-case (return-from ,g!-ordered-choice + (let ((res ,clause)) + ;; (if-debug "|| pre-succeeding") + (values res the-length))) + (simple-esrap-error (e) + (restore-iter-state) + (push e ,g!-parse-errors)))))) + clauses) + (if-debug "|| before failing P ~a L ~a" the-position the-length) + (fail-parse (joinl "~%" + (mapcar (lambda (x) + (slot-value x 'reason)) + (nreverse ,g!-parse-errors)))))) + (if-debug "|| aftermath ~a ~a" the-length ,g!-the-length) + (incf the-length ,g!-the-length) + ,g!-result)))) + +(defmacro most-full-parse (&rest clauses) + (with-gensyms (g!-result g!-the-length g!-successful-parses g!-parse-errors g!-most-full-parse) + `(tracing-level + (if-debug "MOST-FULL-PARSE") + (multiple-value-bind (,g!-result ,g!-the-length) + ;; All this tricky business with BLOCK just for automatic LENGTH tracking. + (block ,g!-most-full-parse + (let (,g!-parse-errors ,g!-successful-parses) + ,@(mapcar (lambda (clause) + `(the-position-boundary + (print-iter-state) + (with-saved-iter-state (the-iter) + (handler-case ,clause + (simple-esrap-error (e) + (restore-iter-state) + (push e ,g!-parse-errors)) + (:no-error (res) + (restore-iter-state) + (push (list res the-length) ,g!-successful-parses)))))) + clauses) + (if ,g!-successful-parses + (destructuring-bind (res length) (car (sort ,g!-successful-parses #'> :key #'cadr)) + (fast-forward the-iter length) + (values res length)) + (progn (if-debug "|| before failing P ~a L ~a" the-position the-length) + (fail-parse (joinl "~%" + (mapcar (lambda (x) + (slot-value x 'reason)) + (nreverse ,g!-parse-errors)))))))) + (if-debug "MOST-FULL-PARSE aftermath ~a ~a" the-length ,g!-the-length) + (incf the-length ,g!-the-length) + ,g!-result)))) (defmacro ! (expr) @@ -184,75 +181,78 @@ (descend-with-rule 'any-token))) -(defmacro! times (subexpr &key from upto exactly) - (flet ((frob (condition) - `(let (,g!-result) - (tracing-level - (iter ,(if (or upto exactly) - `(for ,g!-i from 1 to ,(or upto exactly))) - (if-debug "TIMES") - ;; (print-iter-state the-iter) - (multiple-value-bind (,g!-subresult ,g!-the-length) - (with-saved-iter-state (the-iter) - ;; (format t " Inside subexpression:~%") - (handler-case (the-position-boundary - (let ((subexpr ,subexpr)) - ;; (format t " succeeding ~s ~a~%" subexpr the-length) - ;; (print-iter-state the-iter) - (values subexpr the-length))) - (simple-esrap-error () - ;; (format t " failing~%") - (restore-iter-state) - (finish)))) - (if-first-time nil - (if (equal ,g!-the-length 0) - (terminate))) - (push ,g!-subresult ,g!-result) - (incf the-length ,g!-the-length)) - (finally (if ,condition - (return (make-result (nreverse ,g!-result))) - (fail-parse "Greedy repetition failed.")))))))) - (cond (exactly (if (or from upto) - (error "keywords :EXACTLY and :FROM/:UPTO are mutually exclusive.") - (frob `(equal (length ,g!-result) ,exactly)))) - (from (if upto - (frob `(and (>= (length ,g!-result) ,from) - (<= (length ,g!-result) ,upto))) - (frob `(>= (length ,g!-result) ,from)))) - (upto (frob `(<= (length ,g!-result) ,upto))) - (t (frob t))))) +(defmacro times (subexpr &key from upto exactly) + (with-gensyms (g!-result g!-i g!-subresult g!-the-length) + (flet ((frob (condition) + `(let (,g!-result) + (tracing-level + (iter ,(if (or upto exactly) + `(for ,g!-i from 1 to ,(or upto exactly))) + (if-debug "TIMES") + ;; (print-iter-state the-iter) + (multiple-value-bind (,g!-subresult ,g!-the-length) + (with-saved-iter-state (the-iter) + ;; (format t " Inside subexpression:~%") + (handler-case (the-position-boundary + (let ((subexpr ,subexpr)) + ;; (format t " succeeding ~s ~a~%" subexpr the-length) + ;; (print-iter-state the-iter) + (values subexpr the-length))) + (simple-esrap-error () + ;; (format t " failing~%") + (restore-iter-state) + (finish)))) + (if-first-time nil + (if (equal ,g!-the-length 0) + (terminate))) + (push ,g!-subresult ,g!-result) + (incf the-length ,g!-the-length)) + (finally (if ,condition + (return (make-result (nreverse ,g!-result))) + (fail-parse "Greedy repetition failed.")))))))) + (cond (exactly (if (or from upto) + (error "keywords :EXACTLY and :FROM/:UPTO are mutually exclusive.") + (frob `(equal (length ,g!-result) ,exactly)))) + (from (if upto + (frob `(and (>= (length ,g!-result) ,from) + (<= (length ,g!-result) ,upto))) + (frob `(>= (length ,g!-result) ,from)))) + (upto (frob `(<= (length ,g!-result) ,upto))) + (t (frob t)))))) (defmacro postimes (subexpr) `(times ,subexpr :from 1)) -(defmacro! pred (predicate subexpr) - `(tracing-level - (if-debug "PREDICATE") - (let ((,g!-it ,subexpr)) - (if (funcall ,predicate ,g!-it) - ,g!-it - (fail-parse "Predicate test failed"))))) +(defmacro pred (predicate subexpr) + (with-gensyms (g!-it) + `(tracing-level + (if-debug "PREDICATE") + (let ((,g!-it ,subexpr)) + (if (funcall ,predicate ,g!-it) + ,g!-it + (fail-parse "Predicate test failed")))))) (defmacro progm (start meat end) "Prog Middle." `(progn ,start (prog1 ,meat ,end))) -(defmacro! ? (subexpr) - `(tracing-level - (if-debug "? ~a ~a" the-position the-length) - (multiple-value-bind (,g!-result ,g!-the-length) - (block ,g!-? - (the-position-boundary - (print-iter-state) - (with-saved-iter-state (the-iter) - (handler-case ,subexpr - (simple-esrap-error () - (restore-iter-state) - (values nil nil)) - (:no-error (result) (return-from ,g!-? (values result the-length))))))) - (when ,g!-the-length - (incf the-length ,g!-the-length)) - ,g!-result))) +(defmacro ? (subexpr) + (with-gensyms (g!-? g!-result g!-the-length) + `(tracing-level + (if-debug "? ~a ~a" the-position the-length) + (multiple-value-bind (,g!-result ,g!-the-length) + (block ,g!-? + (the-position-boundary + (print-iter-state) + (with-saved-iter-state (the-iter) + (handler-case ,subexpr + (simple-esrap-error () + (restore-iter-state) + (values nil nil)) + (:no-error (result) (return-from ,g!-? (values result the-length))))))) + (when ,g!-the-length + (incf the-length ,g!-the-length)) + ,g!-result)))) (defmacro & (subexpr) `(tracing-level @@ -275,7 +275,7 @@ (restore-iter-state))) (make-result nil))))) -(defmacro! <- (subexpr) +(defmacro <- (subexpr) `(tracing-level (if-debug "<-") ,(if (and (symbolp subexpr) (equal (string subexpr) "SOF")) @@ -291,21 +291,9 @@ nil)))) -(defmacro! cond-parse (&rest clauses) +(defmacro cond-parse (&rest clauses) `(|| ,@(mapcar (lambda (clause) `(progn ,@clause)) clauses))) - -(defun crunch-c!-s (pre-body) - (declare (special c!-vars)) - ;; (format t "pre-body ~a~%" pre-body) - (destructuring-bind (labels ((name args . body)) - . body2) pre-body - (declare (ignore labels)) - `(labels ((,name ,args - (let ,(iter (for (key nil) in-hashtable c!-vars) - (collect key)) - ,@body))) - ,@body2))) diff --git a/src/memoization.lisp b/src/memoization.lisp index 4245b75..87aa81a 100644 --- a/src/memoization.lisp +++ b/src/memoization.lisp @@ -68,42 +68,43 @@ (defun failed-parse-p (e) (typep e 'simple-esrap-error)) -(defmacro! with-cached-result ((symbol &rest args) &body forms) - `(let* ((,g!-cache *cache*) - (,g!-args (list ,@args)) - (,g!-position (+ the-position the-length)) - (,g!-result (get-cached ',symbol ,g!-position ,g!-args ,g!-cache)) - (*nonterminal-stack* (cons ',symbol *nonterminal-stack*))) - (cond ((eq :left-recursion ,g!-result) - (error 'left-recursion - :position ,g!-position - :nonterminal ',symbol - :path (reverse *nonterminal-stack*))) - (,g!-result (if-debug "~a (~{~s~^ ~}) ~a ~a: CACHED" ',symbol ,g!-args ,g!-position ,g!-result) - (print-iter-state the-iter) - (if (failed-parse-p ,g!-result) - (error ,g!-result) - (progn (incf the-length (cdr ,g!-result)) - (fast-forward the-iter (cdr ,g!-result)) - (car ,g!-result)))) - (t - (if-debug "~a (~{~s~^ ~}) ~a ~a: NEW" ',symbol ,g!-args ,g!-position ,g!-result) - (print-iter-state the-iter) - ;; First mark this pair with :LEFT-RECURSION to detect left-recursion, - ;; then compute the result and cache that. - (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) :left-recursion) - (multiple-value-bind (result length) - (handler-case (the-position-boundary - (values (progn ,@forms) the-length)) - (simple-esrap-error (e) (values e :error))) - ;; (if-debug "after evaluation anew ~a ~a" length the-length) - ;; LENGTH is non-NIL only for successful parses - (cond ((eq :error length) (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) - result) - (error result)) - ((null length) (error "For some reason, length is NIL in memoization")) - (t (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) - (cons result length)) - (incf the-length length) - (if-debug "after setting cache ~a" the-length) - result))))))) +(defmacro with-cached-result ((symbol &rest args) &body forms) + (with-gensyms (g!-cache g!-args g!-position g!-result) + `(let* ((,g!-cache *cache*) + (,g!-args (list ,@args)) + (,g!-position (+ the-position the-length)) + (,g!-result (get-cached ',symbol ,g!-position ,g!-args ,g!-cache)) + (*nonterminal-stack* (cons ',symbol *nonterminal-stack*))) + (cond ((eq :left-recursion ,g!-result) + (error 'left-recursion + :position ,g!-position + :nonterminal ',symbol + :path (reverse *nonterminal-stack*))) + (,g!-result (if-debug "~a (~{~s~^ ~}) ~a ~a: CACHED" ',symbol ,g!-args ,g!-position ,g!-result) + (print-iter-state the-iter) + (if (failed-parse-p ,g!-result) + (error ,g!-result) + (progn (incf the-length (cdr ,g!-result)) + (fast-forward the-iter (cdr ,g!-result)) + (car ,g!-result)))) + (t + (if-debug "~a (~{~s~^ ~}) ~a ~a: NEW" ',symbol ,g!-args ,g!-position ,g!-result) + (print-iter-state the-iter) + ;; First mark this pair with :LEFT-RECURSION to detect left-recursion, + ;; then compute the result and cache that. + (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) :left-recursion) + (multiple-value-bind (result length) + (handler-case (the-position-boundary + (values (progn ,@forms) the-length)) + (simple-esrap-error (e) (values e :error))) + ;; (if-debug "after evaluation anew ~a ~a" length the-length) + ;; LENGTH is non-NIL only for successful parses + (cond ((eq :error length) (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) + result) + (error result)) + ((null length) (error "For some reason, length is NIL in memoization")) + (t (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) + (cons result length)) + (incf the-length length) + (if-debug "after setting cache ~a" the-length) + result)))))))) diff --git a/src/package.lisp b/src/package.lisp index c01885e..b81baaf 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -7,8 +7,7 @@ (in-package #:cl-user) (defpackage :esrap-liquid - (:use #:cl #:alexandria #:defmacro-enhance #:iterate #:cl-indeterminism #:cl-read-macro-tokens) - (:shadowing-import-from #:rutils.string #:strcat) + (:use #:cl #:alexandria #:iterate) (:export #:! #:? #:& #:~ #:<- #:-> #:!! #:times #:postimes #:pred #:progm #:cond-parse #:character-ranges #:most-full-parse diff --git a/tests/package.lisp b/tests/package.lisp index 50637f7..0baee82 100644 --- a/tests/package.lisp +++ b/tests/package.lisp @@ -8,8 +8,8 @@ (in-package :cl-user) (defpackage :esrap-liquid-tests - (:use :alexandria :cl :esrap-liquid :fiveam #:iterate) - (:shadowing-import-from :esrap-liquid "!" "!!") + (:use #:alexandria #:cl #:esrap-liquid #:fiveam #:iterate) + (:shadowing-import-from #:esrap-liquid #:! #:!!) (:export #:run-tests)) (in-package :esrap-liquid-tests) diff --git a/tests/tests.lisp b/tests/tests.lisp index 04760cd..85f99be 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -86,6 +86,7 @@ (parse 'left-recursion "l")) (handler-case (parse 'left-recursion "l") (esrap-liquid::left-recursion (condition) + (declare (ignorable condition)) ;; (is (string= "l" (esrap-liquid::esrap-error-text condition))) ;; (is (= (esrap-liquid::esrap-error-position condition) 0)) ;; (is (eq (esrap-liquid::left-recursion-nonterminal condition) From 67b7c633f5b3c6f39e4731d5b329043879f1c42c Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Fri, 25 Mar 2016 16:28:52 +0100 Subject: [PATCH 74/95] Towards cap and recap --- src/macro.lisp | 141 +++++++++++++++++++++++++++++++---------------- src/package.lisp | 2 +- tests/rules.lisp | 4 +- tests/tests.lisp | 39 ++++++------- 4 files changed, 118 insertions(+), 68 deletions(-) diff --git a/src/macro.lisp b/src/macro.lisp index 66ac240..278468d 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -22,6 +22,30 @@ (the-length 0)) ,@body)) +(defparameter *cap-stash* nil + "Assoc list used to capture temporary variables") + +(defmacro with-fresh-cap-stash (&body body) + `(let* ((up-cap-stash *cap-stash*) + (*cap-stash* nil)) + (declare (ignorable up-cap-stash)) + ,@body)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun propagate-cap-stash-upwards (up-var down-var body) + (with-gensyms (g!-vals g!-it) + `(let ((,g!-vals (multiple-value-list (progn ,@body)))) + (iter (for (key . val) in ,down-var) + (let ((,g!-it (assoc key ,up-var))) + (if ,g!-it + (setf (cdr ,g!-it) val) + (push (cons key val) ,up-var)))) + (values-list ,g!-vals))))) + +(defmacro with-sub-cap-stash (&body body) + `(with-fresh-cap-stash + ,(propagate-cap-stash-upwards 'up-cap-stash '*cap-stash* body))) + (defun wrap-with-esrap-macrolets (body) `(macrolet ((v (thing &rest args) (cond ((characterp thing) (if args @@ -33,9 +57,29 @@ but it shouldn't") `(descend-with-rule 'string ,thing))) ((symbolp thing) `(descend-with-rule ',thing ,@args)) - (t (error "Don't know how to descend with this : ~a" thing))))) + (t (error "Don't know how to descend with this : ~a" thing)))) + (cap (key val) + (let ((key (intern (string key) "KEYWORD"))) + (with-gensyms (g!-it) + `(let ((,g!-it (assoc ,key *cap-stash*))) + (if ,g!-it + (setf (cdr ,g!-it) ,(maybe-wrap-in-descent val)) + (push (cons ,key ,(maybe-wrap-in-descent val)) *cap-stash*)))))) + (recap (key) + (let ((key (intern (string key) "KEYWORD"))) + (with-gensyms (g!-it) + `(let ((,g!-it (assoc ,key *cap-stash*))) + (if ,g!-it + (cdr ,g!-it) + (fail-parse-format "Key ~a is not captured (unbound)." ,key))))))) ,body)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun maybe-wrap-in-descent (thing) + (cond ((characterp thing) `(descend-with-rule 'character ,thing)) + ((stringp thing) `(descend-with-rule 'string ,thing)) + ((symbolp thing) `(descend-with-rule ',thing)) + (t thing)))) (defun make-rule-lambda (name args body) (multiple-value-bind (reqs opts rest kwds allow-other-keys auxs kwds-p) (parse-ordinary-lambda-list args) @@ -48,14 +92,15 @@ `(named-lambda ,(intern #?"ESRAP-$((string name))") (,@args) ,@(if doc `(,doc)) ,@decls - (with-cached-result (,name ,@reqs - ,@(if rest - `(,rest) - (iter (for (opt-name opt-default opt-supplied-p) in opts) - (collect opt-name) - (if opt-supplied-p - (collect opt-supplied-p))))) - ,@body)))))) + (with-fresh-cap-stash + (with-cached-result (,name ,@reqs + ,@(if rest + `(,rest) + (iter (for (opt-name opt-default opt-supplied-p) in opts) + (collect opt-name) + (if opt-supplied-p + (collect opt-supplied-p))))) + ,@body))))))) @@ -99,7 +144,7 @@ (print-iter-state) (with-saved-iter-state (the-iter) (handler-case (return-from ,g!-ordered-choice - (let ((res ,clause)) + (let ((res (with-sub-cap-stash ,(maybe-wrap-in-descent clause)))) ;; (if-debug "|| pre-succeeding") (values res the-length))) (simple-esrap-error (e) @@ -127,16 +172,18 @@ `(the-position-boundary (print-iter-state) (with-saved-iter-state (the-iter) - (handler-case ,clause - (simple-esrap-error (e) - (restore-iter-state) - (push e ,g!-parse-errors)) - (:no-error (res) - (restore-iter-state) - (push (list res the-length) ,g!-successful-parses)))))) + (with-fresh-cap-stash + (handler-case ,(maybe-wrap-in-descent clause) + (simple-esrap-error (e) + (restore-iter-state) + (push e ,g!-parse-errors)) + (:no-error (res) + (restore-iter-state) + (push (list res the-length *cap-stash*) ,g!-successful-parses))))))) clauses) (if ,g!-successful-parses - (destructuring-bind (res length) (car (sort ,g!-successful-parses #'> :key #'cadr)) + (destructuring-bind (res length stash) (car (sort ,g!-successful-parses #'> :key #'cadr)) + ,(propagate-cap-stash-upwards '*cap-stash* 'stash nil) (fast-forward the-iter length) (values res length)) (progn (if-debug "|| before failing P ~a L ~a" the-position the-length) @@ -155,7 +202,7 @@ (if-debug "! P ~a L ~a" the-position the-length) (the-position-boundary (with-saved-iter-state (the-iter) - (handler-case ,expr + (handler-case (with-fresh-cap-stash ,(maybe-wrap-in-descent expr)) (simple-esrap-error () (restore-iter-state) nil) @@ -171,7 +218,7 @@ (if-debug "!!") (the-position-boundary (with-saved-iter-state (the-iter) - (handler-case ,expr + (handler-case (with-fresh-cap-stash ,(maybe-wrap-in-descent expr)) (simple-esrap-error () (restore-iter-state) nil) @@ -194,7 +241,7 @@ (with-saved-iter-state (the-iter) ;; (format t " Inside subexpression:~%") (handler-case (the-position-boundary - (let ((subexpr ,subexpr)) + (let ((subexpr (with-sub-cap-stash ,(maybe-wrap-in-descent subexpr)))) ;; (format t " succeeding ~s ~a~%" subexpr the-length) ;; (print-iter-state the-iter) (values subexpr the-length))) @@ -227,14 +274,15 @@ (with-gensyms (g!-it) `(tracing-level (if-debug "PREDICATE") - (let ((,g!-it ,subexpr)) - (if (funcall ,predicate ,g!-it) - ,g!-it - (fail-parse "Predicate test failed")))))) + (with-sub-cap-stash + (let ((,g!-it ,(maybe-wrap-in-descent subexpr))) + (if (funcall ,predicate ,g!-it) + ,g!-it + (fail-parse "Predicate test failed"))))))) (defmacro progm (start meat end) "Prog Middle." - `(progn ,start (prog1 ,meat ,end))) + `(progn ,(maybe-wrap-in-descent start) (prog1 ,(maybe-wrap-in-descent meat) ,(maybe-wrap-in-descent end)))) (defmacro ? (subexpr) (with-gensyms (g!-? g!-result g!-the-length) @@ -245,7 +293,7 @@ (the-position-boundary (print-iter-state) (with-saved-iter-state (the-iter) - (handler-case ,subexpr + (handler-case (with-sub-cap-stash ,(maybe-wrap-in-descent subexpr)) (simple-esrap-error () (restore-iter-state) (values nil nil)) @@ -259,36 +307,37 @@ (if-debug "&") (make-result (the-position-boundary (with-saved-iter-state (the-iter) - (let ((it ,subexpr)) + (let ((it (with-sub-cap-stash ,(maybe-wrap-in-descent subexpr)))) (restore-iter-state) it)))))) (defmacro -> (subexpr) - (tracing-level - (if-debug "->") - (if (and (symbolp subexpr) (equal (string subexpr) "EOF")) - `(progn (descend-with-rule 'eof) nil) - `(progn (the-position-boundary - (with-saved-iter-state (the-iter) - ,subexpr - (restore-iter-state))) - (make-result nil))))) + `(tracing-level + (if-debug "->") + ,(if (and (symbolp subexpr) (equal (string subexpr) "EOF")) + `(progn (descend-with-rule 'eof) nil) + `(progn (the-position-boundary + (with-saved-iter-state (the-iter) + (with-sub-cap-stash ,(maybe-wrap-in-descent subexpr)) + (restore-iter-state))) + (make-result nil))))) (defmacro <- (subexpr) `(tracing-level (if-debug "<-") ,(if (and (symbolp subexpr) (equal (string subexpr) "SOF")) `(progn (descend-with-rule 'sof) nil) - `(progn (the-position-boundary - (handler-case (progn (rel-rewind the-iter) - (decf the-position)) - (buffer-error () - (fail-parse "Can't rewind back even by 1 token"))) - ,subexpr - (if (not (equal the-length 1)) - (fail-parse "Parsing of subexpr took more than 1 token."))) - nil)))) + `(with-sub-cap-stash + (the-position-boundary + (handler-case (progn (rel-rewind the-iter) + (decf the-position)) + (buffer-error () + (fail-parse "Can't rewind back even by 1 token"))) + ,(maybe-wrap-in-descent subexpr) + (if (not (equal the-length 1)) + (fail-parse "Parsing of subexpr took more than 1 token."))) + nil)))) (defmacro cond-parse (&rest clauses) diff --git a/src/package.lisp b/src/package.lisp index b81baaf..84c46c4 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -18,5 +18,5 @@ #:defrule #:descend-with-rule #:any-string #:character #:string #:|| #:parse #:text #:fail-parse #:fail-parse-format #:define-esrap-env #:in-esrap-env - #:v #:cap + #:v #:cap #:recap )) diff --git a/tests/rules.lisp b/tests/rules.lisp index 98197eb..a2fc468 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -238,8 +238,8 @@ map)))) (defrule dressed-elegantly () - (v "bar") (v "bar") (v "bar") (cap a (v foo+)) (v "bar") (v "bar") (v "bar") - (recap 1)) + (v "bar") (v "bar") (v "bar") (cap a foo+) (v "bar") (v "bar") (v "bar") + (recap a)) (defrule dressed-elegantly-2 () (|| (progn (v "bar") (v "bar") (v "bar") (cap a foo+) (v "bar") (v "bar") (v "bar")) diff --git a/tests/tests.lisp b/tests/tests.lisp index 85f99be..1bf7485 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -78,7 +78,7 @@ (parse 'list-of-integers "1, "))) (test non-consuming-negation - (is (equal "foo" (parse '(text (list (! (v "bar")) (v "foo"))) "foo")))) + (is (equal "foo" (parse '(text (list (! "bar") (v "foo"))) "foo")))) (test condition.2 "Test signaling of `left-recursion' condition." @@ -99,12 +99,12 @@ (test negation "Test negation in rules." (let* ((text "FooBazBar") - (t1c (text (parse '(postimes (!! (v "Baz"))) text :junk-allowed t))) - (t1e (text (parse '(pred #'identity (postimes (!! (v "Baz")))) text :junk-allowed t))) - (t2c (text (parse '(postimes (!! (v "Bar"))) text :junk-allowed t))) - (t2e (text (parse '(pred #'identity (postimes (!! (v "Bar")))) text :junk-allowed t))) - (t3c (text (parse '(postimes (!! (|| (v "Bar") (v "Baz")))) text :junk-allowed t))) - (t3e (text (parse '(pred #'identity (postimes (!! (|| (v "Bar") (v "Baz"))))) text :junk-allowed t)))) + (t1c (text (parse '(postimes (!! "Baz")) text :junk-allowed t))) + (t1e (text (parse '(pred #'identity (postimes (!! "Baz"))) text :junk-allowed t))) + (t2c (text (parse '(postimes (!! "Bar")) text :junk-allowed t))) + (t2e (text (parse '(pred #'identity (postimes (!! "Bar"))) text :junk-allowed t))) + (t3c (text (parse '(postimes (!! (|| "Bar" "Baz"))) text :junk-allowed t))) + (t3e (text (parse '(pred #'identity (postimes (!! (|| "Bar" "Baz")))) text :junk-allowed t)))) (is (equal "Foo" t1c)) (is (equal "Foo" t1e)) (is (equal "FooBaz" t2c)) @@ -140,17 +140,17 @@ (is (equal '(#\a #\b #\-) (parse '(times (character-ranges (#\a #\z) #\-)) "ab-" :junk-allowed t))) (is (equal nil (parse '(times (character-ranges (#\a #\z) #\-)) "AB-" :junk-allowed t))) (is (equal nil (parse '(times (character-ranges (#\a #\z) #\-)) "ZY-" :junk-allowed t))) - (is (equal '(#\a #\b #\-) (parse '(times (v character-range)) "ab-cd" :junk-allowed t)))) + (is (equal '(#\a #\b #\-) (parse '(times character-range) "ab-cd" :junk-allowed t)))) (test examples-from-readme-test (is (equal '("foo" 3) - (multiple-value-list (parse '(|| (v "foo") (v "bar")) "foo")))) + (multiple-value-list (parse '(|| "foo" "bar") "foo")))) (is (equal '(("foo" "foo" "foo") 9) (multiple-value-list (parse 'foo+ "foofoofoo")))) - (is (eql 123 (parse '(pred #'oddp (v decimal)) "123"))) + (is (eql 123 (parse '(pred #'oddp decimal) "123"))) (is (equal '(nil 0) - (multiple-value-list (parse '(pred #'evenp (v decimal)) "123" :junk-allowed t))))) + (multiple-value-list (parse '(pred #'evenp decimal) "123" :junk-allowed t))))) @@ -177,17 +177,17 @@ (is (equal :error-occured (handler-case (parse '(progn (v context-sensitive) (v word)) "foo") (error () :error-occured)))) (is (equal "out of context word" (parse '(|| (progn (v context-sensitive) (v word)) - (v ooc-word)) + ooc-word) "foo")))) (test followed-by-not-gen - (is (equal '("a" nil "b") (parse '(list (v "a") (-> (v "b")) (v "b")) "ab")))) + (is (equal '("a" nil "b") (parse '(list (v "a") (-> "b") (v "b")) "ab")))) (test preceded-by-not-gen - (is (equal '("a" nil "b") (parse '(list (v "a") (<- (v "a")) (v "b")) "ab"))) - (is (equal '("a" "b") (parse '(list (v "a") (|| (<- (v "b")) (v "b"))) "ab"))) + (is (equal '("a" nil "b") (parse '(list (v "a") (<- "a") (v "b")) "ab"))) + (is (equal '("a" "b") (parse '(list (v "a") (|| (<- "b") (v "b"))) "ab"))) (is (equal '(#\newline (esrap-liquid::eof)) (parse '(list (v #\newline) - (times (progn (<- (v #\newline)) (v esrap-liquid::eof)))) + (times (progn (<- #\newline) (v esrap-liquid::eof)))) #?"\n")))) @@ -204,7 +204,8 @@ (test variable-capturing (is (equal '("foo") (parse 'dressed-elegantly "barbarbarfoobarbarbar"))) - (is (equal '("foo" "foo") (parse 'dressed-elegantly "barbarbarfoofoobarbarbar"))) + (is (equal '("foo" "foo") (parse 'dressed-elegantly "barbarbarfoofoobarbarbar")))) + (is (equal '("foo") (parse 'dressed-elegantly-2 "barbarbarfoobarbarbar"))) (is (equal '("foo" "foo") (parse 'dressed-elegantly-2 "barbarbarfoofoobarbarbar"))) (is (equal '("foo") (parse 'dressed-elegantly-2 "barbarfoobarbar"))) @@ -249,8 +250,8 @@ (is (equal "a" (parse '(progn (v esrap-liquid::sof) (v "a")) "a")))) (test most-full-parse - (is (equal "aaaaa" (parse '(text (most-full-parse (times (v #\a) :exactly 3) - (times (v #\a) :exactly 5))) + (is (equal "aaaaa" (parse '(text (most-full-parse (times #\a :exactly 3) + (times #\a :exactly 5))) "aaaaa")))) ;;; esrap-env From 900599d18d2303909769e102da05b1bcd7007673 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sat, 26 Mar 2016 13:48:55 +0100 Subject: [PATCH 75/95] Fix capturing --- src/macro.lisp | 25 ++++++++++++++++--------- src/package.lisp | 2 +- tests/rules.lisp | 6 +++--- tests/tests.lisp | 3 +-- 4 files changed, 21 insertions(+), 15 deletions(-) diff --git a/src/macro.lisp b/src/macro.lisp index 278468d..db2ca0a 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -26,8 +26,9 @@ "Assoc list used to capture temporary variables") (defmacro with-fresh-cap-stash (&body body) + "Extra level of indirection in *CAP-STASH* is needed to be able to insert new values in it" `(let* ((up-cap-stash *cap-stash*) - (*cap-stash* nil)) + (*cap-stash* (cons nil nil))) (declare (ignorable up-cap-stash)) ,@body)) @@ -35,11 +36,14 @@ (defun propagate-cap-stash-upwards (up-var down-var body) (with-gensyms (g!-vals g!-it) `(let ((,g!-vals (multiple-value-list (progn ,@body)))) - (iter (for (key . val) in ,down-var) - (let ((,g!-it (assoc key ,up-var))) + (iter (for (key . val) in (car ,down-var)) + ;; (format t "Propagating ~a ~a ... " key val) + (let ((,g!-it (assoc key (car ,up-var)))) (if ,g!-it - (setf (cdr ,g!-it) val) - (push (cons key val) ,up-var)))) + (progn ;; (format t "update old~%") + (setf (cdr ,g!-it) val)) + (progn ;; (format t "create new~%") + (push (cons key val) (car ,up-var)))))) (values-list ,g!-vals))))) (defmacro with-sub-cap-stash (&body body) @@ -61,17 +65,20 @@ (cap (key val) (let ((key (intern (string key) "KEYWORD"))) (with-gensyms (g!-it) - `(let ((,g!-it (assoc ,key *cap-stash*))) + `(let ((,g!-it (assoc ,key (car *cap-stash*)))) (if ,g!-it (setf (cdr ,g!-it) ,(maybe-wrap-in-descent val)) - (push (cons ,key ,(maybe-wrap-in-descent val)) *cap-stash*)))))) + (push (cons ,key ,(maybe-wrap-in-descent val)) (car *cap-stash*))))))) (recap (key) (let ((key (intern (string key) "KEYWORD"))) (with-gensyms (g!-it) - `(let ((,g!-it (assoc ,key *cap-stash*))) + `(let ((,g!-it (assoc ,key (car *cap-stash*)))) (if ,g!-it (cdr ,g!-it) - (fail-parse-format "Key ~a is not captured (unbound)." ,key))))))) + (fail-parse-format "Key ~a is not captured (unbound)." ,key)))))) + (recap? (key) + `(handler-case (recap ,key) + (simple-esrap-error (e) nil)))) ,body)) (eval-when (:compile-toplevel :load-toplevel :execute) diff --git a/src/package.lisp b/src/package.lisp index 84c46c4..b7f715c 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -18,5 +18,5 @@ #:defrule #:descend-with-rule #:any-string #:character #:string #:|| #:parse #:text #:fail-parse #:fail-parse-format #:define-esrap-env #:in-esrap-env - #:v #:cap #:recap + #:v #:cap #:recap #:recap? )) diff --git a/tests/rules.lisp b/tests/rules.lisp index a2fc468..a6950e0 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -254,14 +254,14 @@ (times (v "f") :exactly n)) -(defrule cipher () +(defrule cifer () (character-ranges (#\0 #\9))) (defrule recurcapturing () - (v #\() (|| (progn (cap int cipher) (cap rc recurcapturing)) + (v #\() (|| (progn (cap int cifer) (cap rc recurcapturing)) (v #\a)) (v #\)) - (cons (recap int) (recap rc))) + (cons (recap? int) (recap? rc))) (defrule triple-a () (list (v #\a) (v #\a) (v #\a))) diff --git a/tests/tests.lisp b/tests/tests.lisp index 1bf7485..2889547 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -204,8 +204,7 @@ (test variable-capturing (is (equal '("foo") (parse 'dressed-elegantly "barbarbarfoobarbarbar"))) - (is (equal '("foo" "foo") (parse 'dressed-elegantly "barbarbarfoofoobarbarbar")))) - + (is (equal '("foo" "foo") (parse 'dressed-elegantly "barbarbarfoofoobarbarbar"))) (is (equal '("foo") (parse 'dressed-elegantly-2 "barbarbarfoobarbarbar"))) (is (equal '("foo" "foo") (parse 'dressed-elegantly-2 "barbarbarfoofoobarbarbar"))) (is (equal '("foo") (parse 'dressed-elegantly-2 "barbarfoobarbar"))) From 04b115c6f99dea7d9744222b860ad504cdce2f98 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sat, 26 Mar 2016 13:56:02 +0100 Subject: [PATCH 76/95] Delete unused remnants of original esrap --- Makefile | 27 -- TODO.org | 72 --- doc/.gitignore | 2 - doc/Makefile | 21 - doc/docstrings.lisp | 911 -------------------------------------- doc/esrap.texinfo | 232 ---------- doc/style.css | 13 - tools/analytics.script | 13 - tools/splice-to-head.lisp | 11 - web/Makefile | 10 - web/style.css | 55 --- 11 files changed, 1367 deletions(-) delete mode 100644 Makefile delete mode 100644 TODO.org delete mode 100644 doc/.gitignore delete mode 100644 doc/Makefile delete mode 100644 doc/docstrings.lisp delete mode 100644 doc/esrap.texinfo delete mode 100644 doc/style.css delete mode 100644 tools/analytics.script delete mode 100644 tools/splice-to-head.lisp delete mode 100644 web/Makefile delete mode 100644 web/style.css diff --git a/Makefile b/Makefile deleted file mode 100644 index d717920..0000000 --- a/Makefile +++ /dev/null @@ -1,27 +0,0 @@ -.PHONY: doc web wc clean all test - -all: - echo "Targets: clean, wc, doc, test, web" - -clean: - rm -f *.fasl *~ - make -C doc clean - make -C web clean - -wc: - wc -l *.lisp - -doc: - make -C doc - -web: doc - make -C web - -gh-pages: web - rm -rf web-tmp - mv web web-tmp - git checkout gh-pages - cp web-tmp/index.html . - git commit -a -c master - mv web-tmp web - git checkout -f master diff --git a/TODO.org b/TODO.org deleted file mode 100644 index 3cb0a02..0000000 --- a/TODO.org +++ /dev/null @@ -1,72 +0,0 @@ -Esrap TODO -* Optimizations -*** Error vs Success results - We're interested in the production/failure, and the position. - - The vast majority of parses result in failures, and we cons up - a FAILED-PARSE for each. Unless the whole parse fails, the only - thing we are interested in is the position. - - ...and even if the whole parse fails, we use the additional - information only to display a fancy error message. - - So: unless PARSE has been called with :DEBUG T, use the fixnum - indicating the position to indicate a failed parse. - - In the case of a success and matching a sequence we don't really - need the whole result object for each submatch. Maybe return - result as multiple values from each rule, and have - WITH-CACHED-RESULT cons up the object to store it when? -*** Cache - The cache is a big bottleneck. Try out a few different designs. - Early experiments show that while it's easy to make something - that conses less, it's not trivial to make it much faster than the - current simple hash-table based version. - - Some statistics: - - 5-10% of positions in a given text have only failure results. - If we can efficiently record the rules these are for... - - 40-50% of positions in a given text end up with exactly one - successful result, irrespective of number of failures. Not sure - if we can use this. - - 75% of positions in a given text end up with - results. This should make a good estimate for the size of the - cache needed. - - The GC is another related bottleneck. Not because we cons so much, - but because we have this massive cache that keeps being written - to, so we have boxed objects on dirty pages. - - To reduce the GC pressure first optimize the result handling. If - the issue still exists, see the first option below. - - Maybe: Map rule to a position cache. In the position cache, need - to be able to differentiate between 3 states: no result, success, - failure. Need to also be able to store the result. If we store - results in a single global result vector, and use N bits per - position in the position cache: 0 no result, 1 failure, anything - else is the position of the result object in the global vector. - - Maybe: PCL-style multikey cache. - - Maybe: Basic two-level cache. (Version of this on a branch.) - -* Grammar objects - Rules should be contained in grammars, so that symbols like CL:IF - can refer to different rules in different contexts. Grammars can - also enforce rule numbering, making caching results easier. It - should be possible to inherit from other grammars. -* Character classes - Have a standard-grammar that defines things like DIGIT, WHITESPACE, - ASCII, etc. -* Character ranges - Make it easy to specify character ranges, eg. (char #\0 #\9). -* Thread safety - Parsing is currently thread-safe if PARSE has been - compiler-macroexanded. *RULES* needs locking, but isn't used - during actual parsing. -* Transform Subseq - (defrule decimal (+ (or "0" "1" ...)) - (:subseq-function parse-integer)) - - diff --git a/doc/.gitignore b/doc/.gitignore deleted file mode 100644 index 5f9b7fe..0000000 --- a/doc/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -*.html -include diff --git a/doc/Makefile b/doc/Makefile deleted file mode 100644 index 828d3ac..0000000 --- a/doc/Makefile +++ /dev/null @@ -1,21 +0,0 @@ -.PHONY: clean html include doc - -doc: html - -clean: - rm -rf include - rm -f *.pdf *.html *.info - rm -f *.aux *.cp *.fn *.fns *.ky *.log *.pg *.toc *.tp *.tps *.vr - -include: - sbcl \ - --eval '(let ((asdf:*central-registry* (cons #p"../" asdf:*central-registry*))) (require :esrap))' \ - --load docstrings.lisp \ - --eval '(sb-texinfo:generate-includes "include/" (list :esrap) :base-package :esrap)' \ - --eval '(quit)' - -esrap.html: esrap.texinfo style.css docstrings.lisp ../*.lisp ../*.asd - make include - makeinfo --html --no-split --css-include=style.css esrap.texinfo - -html: esrap.html diff --git a/doc/docstrings.lisp b/doc/docstrings.lisp deleted file mode 100644 index f681ad9..0000000 --- a/doc/docstrings.lisp +++ /dev/null @@ -1,911 +0,0 @@ -;;; -*- lisp -*- - -;;;; A docstring extractor for the sbcl manual. Creates -;;;; @include-ready documentation from the docstrings of exported -;;;; symbols of specified packages. - -;;;; This software is part of the SBCL software system. SBCL is in the -;;;; public domain and is provided with absolutely no warranty. See -;;;; the COPYING file for more information. -;;;; -;;;; Written by Rudi Schlatte , mangled -;;;; by Nikodemus Siivola. - -;;;; TODO -;;;; * Verbatim text -;;;; * Quotations -;;;; * Method documentation untested -;;;; * Method sorting, somehow -;;;; * Index for macros & constants? -;;;; * This is getting complicated enough that tests would be good -;;;; * Nesting (currently only nested itemizations work) -;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also -;;;; easily generated) - -;;;; FIXME: The description below is no longer complete. This -;;;; should possibly be turned into a contrib with proper documentation. - -;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely): -;;;; -;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in -;;;; the argument list of the defun / defmacro. -;;;; -;;;; Lines starting with * or - that are followed by intented lines -;;;; are marked up with @itemize. -;;;; -;;;; Lines containing only a SYMBOL that are followed by indented -;;;; lines are marked up as @table @code, with the SYMBOL as the item. - -(eval-when (:compile-toplevel :load-toplevel :execute) - (require 'sb-introspect)) - -(defpackage :sb-texinfo - (:use :cl :sb-mop) - (:shadow #:documentation) - (:export #:generate-includes #:document-package) - (:documentation - "Tools to generate TexInfo documentation from docstrings.")) - -(in-package :sb-texinfo) - -;;;; various specials and parameters - -(defvar *texinfo-output*) -(defvar *texinfo-variables*) -(defvar *documentation-package*) -(defvar *base-package*) - -(defparameter *undocumented-packages* '(sb-pcl sb-int sb-kernel sb-sys sb-c)) - -(defparameter *documentation-types* - '(compiler-macro - function - method-combination - setf - ;;structure ; also handled by `type' - type - variable) - "A list of symbols accepted as second argument of `documentation'") - -(defparameter *character-replacements* - '((#\* . "star") (#\/ . "slash") (#\+ . "plus") - (#\< . "lt") (#\> . "gt") - (#\= . "equals")) - "Characters and their replacement names that `alphanumize' uses. If -the replacements contain any of the chars they're supposed to replace, -you deserve to lose.") - -(defparameter *characters-to-drop* '(#\\ #\` #\') - "Characters that should be removed by `alphanumize'.") - -(defparameter *texinfo-escaped-chars* "@{}" - "Characters that must be escaped with #\@ for Texinfo.") - -(defparameter *itemize-start-characters* '(#\* #\-) - "Characters that might start an itemization in docstrings when - at the start of a line.") - -(defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890*=<>:-+&#'!?/" - "List of characters that make up symbols in a docstring.") - -(defparameter *symbol-delimiters* " ,.!?;[]") - -(defparameter *ordered-documentation-kinds* - '(package type structure condition class macro)) - -;;;; utilities - -(defun flatten (list) - (cond ((null list) - nil) - ((consp (car list)) - (nconc (flatten (car list)) (flatten (cdr list)))) - ((null (cdr list)) - (cons (car list) nil)) - (t - (cons (car list) (flatten (cdr list)))))) - -(defun whitespacep (char) - (find char #(#\tab #\space #\page))) - -(defun setf-name-p (name) - (or (symbolp name) - (and (listp name) (= 2 (length name)) (eq (car name) 'setf)))) - -(defgeneric specializer-name (specializer)) - -(defmethod specializer-name ((specializer eql-specializer)) - (list 'eql (eql-specializer-object specializer))) - -(defmethod specializer-name ((specializer class)) - (class-name specializer)) - -(defun ensure-class-precedence-list (class) - (unless (class-finalized-p class) - (finalize-inheritance class)) - (class-precedence-list class)) - -(defun specialized-lambda-list (method) - ;; courtecy of AMOP p. 61 - (let* ((specializers (method-specializers method)) - (lambda-list (method-lambda-list method)) - (n-required (length specializers))) - (append (mapcar (lambda (arg specializer) - (if (eq specializer (find-class 't)) - arg - `(,arg ,(specializer-name specializer)))) - (subseq lambda-list 0 n-required) - specializers) - (subseq lambda-list n-required)))) - -(defun string-lines (string) - "Lines in STRING as a vector." - (coerce (with-input-from-string (s string) - (loop for line = (read-line s nil nil) - while line collect line)) - 'vector)) - -(defun indentation (line) - "Position of first non-SPACE character in LINE." - (position-if-not (lambda (c) (char= c #\Space)) line)) - -(defun docstring (x doc-type) - (cl:documentation x doc-type)) - -(defun flatten-to-string (list) - (format nil "~{~A~^-~}" (flatten list))) - -(defun alphanumize (original) - "Construct a string without characters like *`' that will f-star-ck -up filename handling. See `*character-replacements*' and -`*characters-to-drop*' for customization." - (let ((name (remove-if (lambda (x) (member x *characters-to-drop*)) - (if (listp original) - (flatten-to-string original) - (string original)))) - (chars-to-replace (mapcar #'car *character-replacements*))) - (flet ((replacement-delimiter (index) - (cond ((or (< index 0) (>= index (length name))) "") - ((alphanumericp (char name index)) "-") - (t "")))) - (loop for index = (position-if #'(lambda (x) (member x chars-to-replace)) - name) - while index - do (setf name (concatenate 'string (subseq name 0 index) - (replacement-delimiter (1- index)) - (cdr (assoc (aref name index) - *character-replacements*)) - (replacement-delimiter (1+ index)) - (subseq name (1+ index)))))) - name)) - -;;;; generating various names - -(defgeneric name (thing) - (:documentation "Name for a documented thing. Names are either -symbols or lists of symbols.")) - -(defmethod name ((symbol symbol)) - symbol) - -(defmethod name ((cons cons)) - cons) - -(defmethod name ((package package)) - (short-package-name package)) - -(defmethod name ((method method)) - (list - (generic-function-name (method-generic-function method)) - (method-qualifiers method) - (specialized-lambda-list method))) - -;;; Node names for DOCUMENTATION instances - -(defgeneric name-using-kind/name (kind name doc)) - -(defmethod name-using-kind/name (kind (name string) doc) - (declare (ignore kind doc)) - name) - -(defmethod name-using-kind/name (kind (name symbol) doc) - (declare (ignore kind)) - (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name)) - -(defmethod name-using-kind/name (kind (name list) doc) - (declare (ignore kind)) - (assert (setf-name-p name)) - (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name))) - -(defmethod name-using-kind/name ((kind (eql 'method)) name doc) - (format nil "~A~{ ~A~} ~A" - (name-using-kind/name nil (first name) doc) - (second name) - (third name))) - -(defun node-name (doc) - "Returns TexInfo node name as a string for a DOCUMENTATION instance." - (let ((kind (get-kind doc))) - (format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc)))) - -(defun short-package-name (package) - (unless (eq package *base-package*) - (car (sort (copy-list (cons (package-name package) (package-nicknames package))) - #'< :key #'length)))) - -;;; Definition titles for DOCUMENTATION instances - -(defgeneric title-using-kind/name (kind name doc)) - -(defmethod title-using-kind/name (kind (name string) doc) - (declare (ignore kind doc)) - name) - -(defmethod title-using-kind/name (kind (name symbol) doc) - (declare (ignore kind)) - (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name)) - -(defmethod title-using-kind/name (kind (name list) doc) - (declare (ignore kind)) - (assert (setf-name-p name)) - (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name))) - -(defmethod title-using-kind/name ((kind (eql 'method)) name doc) - (format nil "~{~A ~}~A" - (second name) - (title-using-kind/name nil (first name) doc))) - -(defun title-name (doc) - "Returns a string to be used as name of the definition." - (string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc))) - -(defun include-pathname (doc) - (let* ((kind (get-kind doc)) - (name (nstring-downcase - (if (eq 'package kind) - (format nil "package-~A" (alphanumize (get-name doc))) - (format nil "~A-~A-~A" - (case (get-kind doc) - ((function generic-function) "fun") - (structure "struct") - (variable "var") - (otherwise (symbol-name (get-kind doc)))) - (alphanumize (let ((*base-package* nil)) - (short-package-name (get-package doc)))) - (alphanumize (get-name doc))))))) - (make-pathname :name name :type "texinfo"))) - -;;;; documentation class and related methods - -(defclass documentation () - ((name :initarg :name :reader get-name) - (kind :initarg :kind :reader get-kind) - (string :initarg :string :reader get-string) - (children :initarg :children :initform nil :reader get-children) - (package :initform *documentation-package* :reader get-package))) - -(defmethod print-object ((documentation documentation) stream) - (print-unreadable-object (documentation stream :type t) - (princ (list (get-kind documentation) (get-name documentation)) stream))) - -(defgeneric make-documentation (x doc-type string)) - -(defmethod make-documentation ((x package) doc-type string) - (declare (ignore doc-type)) - (make-instance 'documentation - :name (name x) - :kind 'package - :string string)) - -(defmethod make-documentation (x (doc-type (eql 'function)) string) - (declare (ignore doc-type)) - (let* ((fdef (and (fboundp x) (fdefinition x))) - (name x) - (kind (cond ((and (symbolp x) (special-operator-p x)) - 'special-operator) - ((and (symbolp x) (macro-function x)) - 'macro) - ((typep fdef 'generic-function) - (assert (or (symbolp name) (setf-name-p name))) - 'generic-function) - (fdef - (assert (or (symbolp name) (setf-name-p name))) - 'function))) - (children (when (eq kind 'generic-function) - (collect-gf-documentation fdef)))) - (make-instance 'documentation - :name (name x) - :string string - :kind kind - :children children))) - -(defmethod make-documentation ((x method) doc-type string) - (declare (ignore doc-type)) - (make-instance 'documentation - :name (name x) - :kind 'method - :string string)) - -(defmethod make-documentation (x (doc-type (eql 'type)) string) - (make-instance 'documentation - :name (name x) - :string string - :kind (etypecase (find-class x nil) - (structure-class 'structure) - (standard-class 'class) - (sb-pcl::condition-class 'condition) - ((or built-in-class null) 'type)))) - -(defmethod make-documentation (x (doc-type (eql 'variable)) string) - (make-instance 'documentation - :name (name x) - :string string - :kind (if (constantp x) - 'constant - 'variable))) - -(defmethod make-documentation (x (doc-type (eql 'setf)) string) - (declare (ignore doc-type)) - (make-instance 'documentation - :name (name x) - :kind 'setf-expander - :string string)) - -(defmethod make-documentation (x doc-type string) - (make-instance 'documentation - :name (name x) - :kind doc-type - :string string)) - -(defun maybe-documentation (x doc-type) - "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if -there is no corresponding docstring." - (let ((docstring (docstring x doc-type))) - (when docstring - (make-documentation x doc-type docstring)))) - -(defun lambda-list (doc) - (case (get-kind doc) - ((package constant variable type structure class condition nil) - nil) - (method - (third (get-name doc))) - (t - ;; KLUDGE: Eugh. - ;; - ;; believe it or not, the above comment was written before CSR - ;; came along and obfuscated this. (2005-07-04) - (let ((name (get-name doc))) - (when (or (symbolp name) - (and (consp name) (eq 'setf (car name)))) - (labels ((clean (x &key optional key) - (typecase x - (atom x) - ((cons (member &optional)) - (cons (car x) (clean (cdr x) :optional t))) - ((cons (member &key)) - (cons (car x) (clean (cdr x) :key t))) - ((cons (member &whole &environment)) - ;; Skip these - (clean (cddr x) :optional optional :key key)) - ((cons (member &aux)) - ;; Drop everything after &AUX. - nil) - ((cons cons) - (cons - (cond (key (if (consp (caar x)) - (caaar x) - (caar x))) - (optional (caar x)) - (t (clean (car x)))) - (clean (cdr x) :key key :optional optional))) - (cons - (cons - (cond ((or key optional) (car x)) - (t (clean (car x)))) - (clean (cdr x) :key key :optional optional)))))) - (clean (sb-introspect:function-lambda-list name)))))))) - -(defun get-string-name (x) - (let ((name (get-name x))) - (cond ((symbolp name) - (symbol-name name)) - ((and (consp name) (eq 'setf (car name))) - (symbol-name (second name))) - ((stringp name) - name) - (t - (error "Don't know which symbol to use for name ~S" name))))) - -(defun documentation< (x y) - (let ((p1 (position (get-kind x) *ordered-documentation-kinds*)) - (p2 (position (get-kind y) *ordered-documentation-kinds*))) - (if (or (not (and p1 p2)) (= p1 p2)) - (string< (get-string-name x) (get-string-name y)) - (< p1 p2)))) - -;;;; turning text into texinfo - -(defun escape-for-texinfo (string &optional downcasep) - "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped -with #\@. Optionally downcase the result." - (let ((result (with-output-to-string (s) - (loop for char across string - when (find char *texinfo-escaped-chars*) - do (write-char #\@ s) - do (write-char char s))))) - (if downcasep (nstring-downcase result) result))) - -(defun empty-p (line-number lines) - (and (< -1 line-number (length lines)) - (not (indentation (svref lines line-number))))) - -;;; line markups - -(defvar *not-symbols* '("ANSI" "CLHS")) - -(defun frob-ellipsis (line) - (let ((p (search "..." line))) - (if p - (frob-ellipsis (replace (copy-seq line) "+++" :start1 p)) - line))) - -(defun locate-symbols (line) - "Return a list of index pairs of symbol-like parts of LINE." - ;; This would be a good application for a regex ... - (let (result) - (flet ((grab (start end) - (unless (member (subseq line start end) *not-symbols*) - (push (list start end) result))) - (got-symbol-p (start) - (let ((end (when (< start (length line)) - (position-if (lambda (char) (find char " )")) - line :start start)))) - (when end - (every (lambda (char) (find char *symbol-characters*)) - (subseq line start end)))))) - (do ((begin nil) - (maybe-begin t) - (i 0 (1+ i))) - ((>= i (length line)) - ;; symbol at end of line - (when (and begin (or (> i (1+ begin)) - (not (member (char line begin) '(#\A #\I))))) - (grab begin i)) - (nreverse result)) - (cond - ((and begin (find (char line i) *symbol-delimiters*)) - ;; symbol end; remember it if it's not "A" or "I" - (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I)))) - (grab begin i)) - (setf begin nil - maybe-begin t)) - ((and begin (not (find (char line i) *symbol-characters*))) - ;; Not a symbol: abort - (setf begin nil)) - ((and maybe-begin (not begin) (find (char line i) *symbol-characters*)) - ;; potential symbol begin at this position - (setf begin i - maybe-begin nil)) - ((find (char line i) *symbol-delimiters*) - ;; potential symbol begin after this position - (setf maybe-begin t)) - ((and (eql #\( (char line i)) (got-symbol-p (1+ i))) - ;; a type designator, or a function call as part of the text? - (multiple-value-bind (exp end) - (let ((*package* (find-package :cl-user))) - (ignore-errors (read-from-string (frob-ellipsis line) nil nil :start i))) - (when exp - (grab i end) - (setf begin nil - maybe-begin nil - i end)))) - (t - ;; Not reading a symbol, not at potential start of symbol - (setf maybe-begin nil))))))) - -(defun texinfo-line (line) - "Format symbols in LINE texinfo-style: either as code or as -variables if the symbol in question is contained in symbols -*TEXINFO-VARIABLES*." - (with-output-to-string (result) - (let ((last 0)) - (dolist (symbol/index (locate-symbols line)) - (write-string (subseq line last (first symbol/index)) result) - (let ((symbol-name (apply #'subseq line symbol/index))) - (format result (if (member symbol-name *texinfo-variables* - :test #'string=) - "@var{~A}" - "@code{~A}") - (string-downcase symbol-name))) - (setf last (second symbol/index))) - (write-string (subseq line last) result)))) - -;;; lisp sections - -(defun lisp-section-p (line line-number lines) - "Returns T if the given LINE looks like start of lisp code -- -ie. if it starts with whitespace followed by a paren or -semicolon, and the previous line is empty" - (let ((offset (indentation line))) - (and offset - (plusp offset) - (find (find-if-not #'whitespacep line) "(;") - (empty-p (1- line-number) lines)))) - -(defun collect-lisp-section (lines line-number) - (let ((lisp (loop for index = line-number then (1+ index) - for line = (and (< index (length lines)) (svref lines index)) - while (indentation line) - collect line))) - ;; KLUDGE: makeinfo likes to stick an newline after @lisp sections - ;; we generate, so balance it out by adding one before. Grr. - (values (length lisp) `("@lisp" "" ,@lisp "@end lisp")))) - -;;; itemized sections - -(defun maybe-itemize-offset (line) - "Return NIL or the indentation offset if LINE looks like it starts -an item in an itemization." - (let* ((offset (indentation line)) - (char (when offset (char line offset)))) - (and offset - (member char *itemize-start-characters* :test #'char=) - (char= #\Space (find-if-not (lambda (c) (char= c char)) - line :start offset)) - offset))) - -(defun collect-maybe-itemized-section (lines starting-line) - ;; Return index of next line to be processed outside - (let ((this-offset (maybe-itemize-offset (svref lines starting-line))) - (result nil) - (lines-consumed 0)) - (loop for line-number from starting-line below (length lines) - for line = (svref lines line-number) - for indentation = (indentation line) - for offset = (maybe-itemize-offset line) - do (cond - ((not indentation) - ;; empty line -- inserts paragraph. - (push "" result) - (incf lines-consumed)) - ((and offset (> indentation this-offset)) - ;; nested itemization -- handle recursively - ;; FIXME: tables in itemizations go wrong - (multiple-value-bind (sub-lines-consumed sub-itemization) - (collect-maybe-itemized-section lines line-number) - (when sub-lines-consumed - (incf line-number (1- sub-lines-consumed)) ; +1 on next loop - (incf lines-consumed sub-lines-consumed) - (setf result (nconc (nreverse sub-itemization) result))))) - ((and offset (= indentation this-offset)) - ;; start of new item - (push (format nil "@item ~A" - (texinfo-line (subseq line (1+ offset)))) - result) - (incf lines-consumed)) - ((and (not offset) (> indentation this-offset)) - ;; continued item from previous line - (push (texinfo-line line) result) - (incf lines-consumed)) - (t - ;; end of itemization - (loop-finish)))) - ;; a single-line itemization isn't. - (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) - (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize")) - nil))) - -;;; table sections - -(defun tabulation-body-p (offset line-number lines) - (when (< line-number (length lines)) - (let ((offset2 (indentation (svref lines line-number)))) - (and offset2 (< offset offset2))))) - -(defun tabulation-p (offset line-number lines direction) - (let ((step (ecase direction - (:backwards (1- line-number)) - (:forwards (1+ line-number))))) - (when (and (plusp line-number) (< line-number (length lines))) - (and (eql offset (indentation (svref lines line-number))) - (or (when (eq direction :backwards) - (empty-p step lines)) - (tabulation-p offset step lines direction) - (tabulation-body-p offset step lines)))))) - -(defun maybe-table-offset (line-number lines) - "Return NIL or the indentation offset if LINE looks like it starts -an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an -empty line, another tabulation label, or a tabulation body, (3) and -followed another tabulation label or a tabulation body." - (let* ((line (svref lines line-number)) - (offset (indentation line)) - (prev (1- line-number)) - (next (1+ line-number))) - (when (and offset (plusp offset)) - (and (or (empty-p prev lines) - (tabulation-body-p offset prev lines) - (tabulation-p offset prev lines :backwards)) - (or (tabulation-body-p offset next lines) - (tabulation-p offset next lines :forwards)) - offset)))) - -;;; FIXME: This and itemization are very similar: could they share -;;; some code, mayhap? - -(defun collect-maybe-table-section (lines starting-line) - ;; Return index of next line to be processed outside - (let ((this-offset (maybe-table-offset starting-line lines)) - (result nil) - (lines-consumed 0)) - (loop for line-number from starting-line below (length lines) - for line = (svref lines line-number) - for indentation = (indentation line) - for offset = (maybe-table-offset line-number lines) - do (cond - ((not indentation) - ;; empty line -- inserts paragraph. - (push "" result) - (incf lines-consumed)) - ((and offset (= indentation this-offset)) - ;; start of new item, or continuation of previous item - (if (and result (search "@item" (car result) :test #'char=)) - (push (format nil "@itemx ~A" (texinfo-line line)) - result) - (progn - (push "" result) - (push (format nil "@item ~A" (texinfo-line line)) - result))) - (incf lines-consumed)) - ((> indentation this-offset) - ;; continued item from previous line - (push (texinfo-line line) result) - (incf lines-consumed)) - (t - ;; end of itemization - (loop-finish)))) - ;; a single-line table isn't. - (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) - (values lines-consumed - `("" "@table @emph" ,@(reverse result) "@end table" "")) - nil))) - -;;; section markup - -(defmacro with-maybe-section (index &rest forms) - `(multiple-value-bind (count collected) (progn ,@forms) - (when count - (dolist (line collected) - (write-line line *texinfo-output*)) - (incf ,index (1- count))))) - -(defun write-texinfo-string (string &optional lambda-list) - "Try to guess as much formatting for a raw docstring as possible." - (let ((*texinfo-variables* (flatten lambda-list)) - (lines (string-lines (escape-for-texinfo string nil)))) - (loop for line-number from 0 below (length lines) - for line = (svref lines line-number) - do (cond - ((with-maybe-section line-number - (and (lisp-section-p line line-number lines) - (collect-lisp-section lines line-number)))) - ((with-maybe-section line-number - (and (maybe-itemize-offset line) - (collect-maybe-itemized-section lines line-number)))) - ((with-maybe-section line-number - (and (maybe-table-offset line-number lines) - (collect-maybe-table-section lines line-number)))) - (t - (write-line (texinfo-line line) *texinfo-output*)))))) - -;;;; texinfo formatting tools - -(defun hide-superclass-p (class-name super-name) - (let ((super-package (symbol-package super-name))) - (or - ;; KLUDGE: We assume that we don't want to advertise internal - ;; classes in CP-lists, unless the symbol we're documenting is - ;; internal as well. - (and (member super-package #.'(mapcar #'find-package *undocumented-packages*)) - (not (eq super-package (symbol-package class-name)))) - ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or - ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them - ;; simply as a matter of convenience. The assumption here is that - ;; the inheritance is incidental unless the name of the condition - ;; begins with SIMPLE-. - (and (member super-name '(simple-error simple-condition)) - (let ((prefix "SIMPLE-")) - (mismatch prefix (string class-name) :end2 (length prefix))) - t ; don't return number from MISMATCH - )))) - -(defun hide-slot-p (symbol slot) - ;; FIXME: There is no pricipal reason to avoid the slot docs fo - ;; structures and conditions, but their DOCUMENTATION T doesn't - ;; currently work with them the way we'd like. - (not (and (typep (find-class symbol nil) 'standard-class) - (docstring slot t)))) - -(defun texinfo-anchor (doc) - (format *texinfo-output* "@anchor{~A}~%" (node-name doc))) - -;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please" -(defun texinfo-begin (doc &aux *print-pretty*) - (let ((kind (get-kind doc))) - (format *texinfo-output* "@~A {~:(~A~)} ~({~A}~@[ ~{~A~^ ~}~]~)~%" - (case kind - ((package constant variable) - "defvr") - ((structure class condition type) - "deftp") - (t - "deffn")) - (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind)) - (title-name doc) - ;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo - ;; interactions,so we escape the ampersand -- amusingly for TeX. - ;; sbcl.texinfo defines macros that expand @&key and friends to &key. - (mapcar (lambda (name) - (if (member name lambda-list-keywords) - (format nil "@~A" name) - name)) - (lambda-list doc))))) - -(defun texinfo-index (doc) - (let ((title (title-name doc))) - (case (get-kind doc) - ((structure type class condition) - (format *texinfo-output* "@tindex ~A~%" title)) - ((variable constant) - (format *texinfo-output* "@vindex ~A~%" title)) - ((compiler-macro function method-combination macro generic-function) - (format *texinfo-output* "@findex ~A~%" title))))) - -(defun texinfo-inferred-body (doc) - (when (member (get-kind doc) '(class structure condition)) - (let ((name (get-name doc))) - ;; class precedence list - (format *texinfo-output* "Class precedence list: @code{~(~{~(~A~)~^, ~}~)}~%~%" - (remove-if (lambda (class) (hide-superclass-p name class)) - (mapcar #'class-name (ensure-class-precedence-list (find-class name))))) - ;; slots - (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot)) - (class-direct-slots (find-class name))))) - (when slots - (format *texinfo-output* "Slots:~%@itemize~%") - (dolist (slot slots) - (format *texinfo-output* - "@item ~(@code{~A}~#[~:; --- ~]~ - ~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%" - (slot-definition-name slot) - (remove - nil - (mapcar - (lambda (name things) - (if things - (list name (length things) things))) - '("initarg" "reader" "writer") - (list - (slot-definition-initargs slot) - (slot-definition-readers slot) - (slot-definition-writers slot))))) - ;; FIXME: Would be neater to handler as children - (write-texinfo-string (docstring slot t))) - (format *texinfo-output* "@end itemize~%~%")))))) - -(defun texinfo-body (doc) - (write-texinfo-string (get-string doc))) - -(defun texinfo-end (doc) - (write-line (case (get-kind doc) - ((package variable constant) "@end defvr") - ((structure type class condition) "@end deftp") - (t "@end deffn")) - *texinfo-output*)) - -(defun write-texinfo (doc) - "Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*." - (texinfo-anchor doc) - (texinfo-begin doc) - (texinfo-index doc) - (texinfo-inferred-body doc) - (texinfo-body doc) - (texinfo-end doc) - ;; FIXME: Children should be sorted one way or another - (mapc #'write-texinfo (get-children doc))) - -;;;; main logic - -(defun collect-gf-documentation (gf) - "Collects method documentation for the generic function GF" - (loop for method in (generic-function-methods gf) - for doc = (maybe-documentation method t) - when doc - collect doc)) - -(defun collect-name-documentation (name) - (loop for type in *documentation-types* - for doc = (maybe-documentation name type) - when doc - collect doc)) - -(defun collect-symbol-documentation (symbol) - "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of -the form DOC instances. See `*documentation-types*' for the possible -values of doc-type." - (nconc (collect-name-documentation symbol) - (collect-name-documentation (list 'setf symbol)))) - -(defun collect-documentation (package) - "Collects all documentation for all external symbols of the given -package, as well as for the package itself." - (let* ((*documentation-package* (find-package package)) - (docs nil)) - (check-type package package) - (do-external-symbols (symbol package) - (setf docs (nconc (collect-symbol-documentation symbol) docs))) - (let ((doc (maybe-documentation *documentation-package* t))) - (when doc - (push doc docs))) - docs)) - -(defmacro with-texinfo-file (pathname &body forms) - `(with-open-file (*texinfo-output* ,pathname - :direction :output - :if-does-not-exist :create - :if-exists :supersede) - ,@forms)) - -(defun write-ifnottex () - ;; We use @&key, etc to escape & from TeX in lambda lists -- so we need to - ;; define them for info as well. - (flet ((macro (name) - (let ((string (string-downcase name))) - (format *texinfo-output* "@macro ~A~%~A~%@end macro~%" string string)))) - (macro '&allow-other-keys) - (macro '&optional) - (macro '&rest) - (macro '&key) - (macro '&body))) - -(defun generate-includes (directory packages &key (base-package :cl-user)) - "Create files in `directory' containing Texinfo markup of all -docstrings of each exported symbol in `packages'. `directory' is -created if necessary. If you supply a namestring that doesn't end in a -slash, you lose. The generated files are of the form -\"__.texinfo\" and can be included -via @include statements. Texinfo syntax-significant characters are -escaped in symbol names, but if a docstring contains invalid Texinfo -markup, you lose." - (handler-bind ((warning #'muffle-warning)) - (let ((directory (merge-pathnames (pathname directory))) - (*base-package* (find-package base-package))) - (ensure-directories-exist directory) - (dolist (package packages) - (dolist (doc (collect-documentation (find-package package))) - (with-texinfo-file (merge-pathnames (include-pathname doc) directory) - (write-texinfo doc)))) - (with-texinfo-file (merge-pathnames "ifnottex.texinfo" directory) - (write-ifnottex)) - directory))) - -(defun document-package (package &optional filename) - "Create a file containing all available documentation for the -exported symbols of `package' in Texinfo format. If `filename' is not -supplied, a file \".texinfo\" is generated. - -The definitions can be referenced using Texinfo statements like -@ref{__.texinfo}. Texinfo -syntax-significant characters are escaped in symbol names, but if a -docstring contains invalid Texinfo markup, you lose." - (handler-bind ((warning #'muffle-warning)) - (let* ((package (find-package package)) - (filename (or filename (make-pathname - :name (string-downcase (short-package-name package)) - :type "texinfo"))) - (docs (sort (collect-documentation package) #'documentation<))) - (with-texinfo-file filename - (dolist (doc docs) - (write-texinfo doc))) - filename))) diff --git a/doc/esrap.texinfo b/doc/esrap.texinfo deleted file mode 100644 index 48c5e39..0000000 --- a/doc/esrap.texinfo +++ /dev/null @@ -1,232 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@c %**start of header -@setfilename esrap.info -@settitle Esrap -@c %**end of header - -@settitle Esrap - -@c for install-info -@dircategory Software development -@direntry -* Esrap: a packrat parser for Common Lisp -@end direntry - -@titlepage - -@title Esrap -@subtitle a packrat parser for Common Lisp - -@c The following two commands start the copyright page. -@page -@vskip 0pt plus 1filll -@insertcopying - -@end titlepage - -In addition to regular Packrat / Parsing Grammar / TDPL features Esrap -supports dynamic redefinition of nonterminals, inline grammars, -semantic predicates, and include introspecive facilities for -development. - -Esrap is maintained in Git: -@example -git clone git://github.com/nikodemus/esrap.git -@end example -will get you a local copy. -@example -@url{http://github.com/nikodemus/esrap} -@end example -is the GitHub project page. - -Esrap is licenced under an MIT-style licence. - -For more on packrat parsing, see -@url{http://pdos.csail.mit.edu/~baford/packrat/thesis/} for Bryan Ford's 2002 -thesis: ``Packrat Parsing: a Practical Linear Time Algorithm with Backtracking''. - -@contents - -@ifnottex - -@include include/ifnottex.texinfo - -@end ifnottex - -@chapter Parsing Expressions - -Parsing proceeds by matching text against parsing expressions. -Matching has three components: success vs failure, consumption of -input, and associated production. - -Parsing expressions that fail never consume input. Parsing expressions -that succeed may or may not consume input. - -A parsing expressions can be: - -@heading Terminal -A terminal is a character or a string of length one, which succeeds and -consumes a single character if that character matches the terminal. - -Additionally, Esrap supports some pseudoterminals. - -@itemize -@item -The wild terminal symbol @code{character} always succeeds, consuming -and producing a single character. -@item -Expressions of the form @code{(character-ranges range ...)} match a -single character from the given range(s), consuming and producing that -character. A range is can be either a list of the form -@code{(#\start_char #\stop_char)} or a single character. -@item -Multicharacter strings can be used to specify sequences of terminals: -@code{"foo"} succeeds and consumes input as if @code{(and #\f #\o -#\o)}. Produces the consumed string. -@item -Expressions of the form @code{(string length)} can be used to specify -sequences of arbitrary characters: @code{(string 2)} succeeds and -consumes input as if @code{(and character character)}. Produces the -consumed string. -@end itemize - -@heading Nonterminal -Nonterminals are specified using symbols. A nonterminal symbol -succeeds if the parsing expression associated with it succeeds, and -consumes whatever the input that expression consumes. - -The production of a nonterminal depends on the associated expression -and an optional transformation rule. - -Nonterminals are defined using @code{defrule}. - -@emph{Note: Currently all rules share the same namespace, so you -should not use symbols in the COMMON-LISP package or other shared -packages to name your rules unless you are certain there are no other -Esrap using components in your Lisp image. In a future version of -Esrap grammar objects will be introduced to allow multiple definitions -of nonterminals. Symbols in the COMMON-LISP package are specifically -reserved for use by Esrap.} - -@heading Sequence -@lisp -(and subexpression ...) -@end lisp - -A sequence succeeds if all subexpressions succeed, and consumes all -input consumed by the subexpressions. A sequence produces the -productions of its subexpressions as a list. - -@heading Ordered Choice -@lisp -(or subexpression ...) -@end lisp - -An ordered choice succeeds if any of the subexpressions succeeds, and -consumes all the input consumed by the successful subexpression. An -ordered choice produces whatever the successful subexpression -produces. - -Subexpressions are checked strictly in the specified order, and once -a subexpression succeeds no further ones will be tried. - -@heading Negation -@lisp -(not subexpression) -@end lisp - -A negation succeeds if the subexpression fails, and consumes one character -of input. A negation produces the character it consumes. - -@heading Greedy Repetition -@lisp -(* subexpresssion) -@end lisp - -A greedy repetition always succeeds, consuming all input consumed by -applying subexpression repeatedly as long as it succeeds. - -A greedy repetition produces the productions of the subexpression as a -list. - -@heading Greedy Positive Repetition -@lisp -(+ subexpresssion) -@end lisp - -A greedy repetition succeeds if subexpression succeeds at least once, -and consumes all input consumed by applying subexpression repeatedly -as long as it succeeds. A greedy positive repetition produces the -productions of the subexpression as a list. - -@heading Optional -@lisp -(? subexpression) -@end lisp - -Optionals always succeed, and consume whatever input the subexpression -consumes. An optional produces whatever the subexpression produces, or -@code{nil} if the subexpression does not succeed. - -@heading Followed-By Predicate -@lisp -(& subexpression) -@end lisp - -A followed-by predicate succeeds if the subexpression succeeds, and -@emph{consumes no input}. A followed-by predicate produces whatever -the subexpression produces. - -@heading Not-Followed-By Predicate -@lisp -(! subexpression) -@end lisp - -A not-followed-by predicate succeeds if the subexpression does not -succeed, and @emph{consumes no input}. A not-followed-by predicate -produces @code{nil}. - -@heading Semantic Predicates -@lisp -(predicate-name subexpression) -@end lisp - -The @code{predicate-name} is a symbol naming a global function. A -semantic predicate succeeds if subsexpression succeeds @emph{and} the -named function returns true for the production of the subexpression. A -semantic predicate produces whatever the subexpression produces. - -@emph{Note: semantic predicates may change in the future to produce -whatever the predicate function returns.} - -@chapter Dictionary - -@section Primary Interface - -@include include/macro-esrap-defrule.texinfo -@include include/fun-esrap-parse.texinfo -@include include/fun-esrap-describe-grammar.texinfo - -@section Utilities - -@include include/fun-esrap-text.texinfo - -@section Introspection and Intercession - -@include include/fun-esrap-add-rule.texinfo -@include include/fun-esrap-change-rule.texinfo -@include include/fun-esrap-find-rule.texinfo -@include include/fun-esrap-remove-rule.texinfo -@include include/fun-esrap-rule-dependencies.texinfo -@include include/fun-esrap-rule-expression.texinfo -@include include/fun-esrap-setf-rule-expression.texinfo -@include include/fun-esrap-rule-symbol.texinfo -@include include/fun-esrap-trace-rule.texinfo -@include include/fun-esrap-untrace-rule.texinfo - -@section Error Conditions - -@include include/condition-esrap-esrap-error.texinfo -@include include/condition-esrap-left-recursion.texinfo - -@bye diff --git a/doc/style.css b/doc/style.css deleted file mode 100644 index 7b84939..0000000 --- a/doc/style.css +++ /dev/null @@ -1,13 +0,0 @@ - .node { visibility:hidden; height: 0px; } - .menu { visibility:hidden; height: 0px; } - .chapter { background-color:#e47700; padding: 0.2em; } - .section { background-color:#e47700; padding: 0.2em; } - .settitle { background-color:#e47700; } - .contents { border: 2px solid black; - margin: 1cm 1cm 1cm 1cm; - padding-left: 3mm; } - .lisp { padding: 0; margin: 0em; } - body { padding: 2em 8em; font-family: sans-serif; } - h1 { padding: 1em; text-align: center; } - li { margin: 1em; } - diff --git a/tools/analytics.script b/tools/analytics.script deleted file mode 100644 index 3b75f83..0000000 --- a/tools/analytics.script +++ /dev/null @@ -1,13 +0,0 @@ - diff --git a/tools/splice-to-head.lisp b/tools/splice-to-head.lisp deleted file mode 100644 index 19dbc89..0000000 --- a/tools/splice-to-head.lisp +++ /dev/null @@ -1,11 +0,0 @@ -#!/usr/local/bin/sbcl --script - -;;; Hey, almost like Perl! -(loop for line = (read-line *standard-input* nil nil) - while line - do (when (search "" line) - (with-open-file (f (second *posix-argv*)) - (loop for splice = (read-line f nil nil) - while splice - do (write-line splice *standard-output*)))) - (write-line line *standard-output*)) diff --git a/web/Makefile b/web/Makefile deleted file mode 100644 index 6dee09f..0000000 --- a/web/Makefile +++ /dev/null @@ -1,10 +0,0 @@ -.PHONY: clean - -all: index.html - -index.html: ../doc/esrap.html ../tools/analytics.script - sbcl --script ../tools/splice-to-head.lisp ../tools/analytics.script \ - < ../doc/esrap.html > index.html - -clean: - rm -f *~ *.lisp *.lisp.html \#* diff --git a/web/style.css b/web/style.css deleted file mode 100644 index c44e368..0000000 --- a/web/style.css +++ /dev/null @@ -1,55 +0,0 @@ -body { - color: #000000; - background-color: #ffffff; -} -.builtin { - /* font-lock-builtin-face */ - color: #7a378b; -} -.comment { - /* font-lock-comment-face */ - color: #b22222; -} -.comment-delimiter { - /* font-lock-comment-delimiter-face */ - color: #b22222; -} -.constant { - /* font-lock-constant-face */ - color: #008b8b; -} -.function-name { - /* font-lock-function-name-face */ - color: #0000ff; -} -.keyword { - /* font-lock-keyword-face */ - color: #7f007f; -} -.slime-reader-conditional { - /* slime-reader-conditional-face */ - color: #b22222; -} -.string { - /* font-lock-string-face */ - color: #996633; -} -.type { - /* font-lock-type-face */ - color: #228b22; -} -.warning { - /* font-lock-warning-face */ - color: #ff0000; - font-weight: bold; -} - -a { - color: inherit; - background-color: inherit; - font: inherit; - text-decoration: inherit; -} -a:hover { - text-decoration: underline; -} From 155470071bfc60854a8a10fe4158be5e85965881 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sat, 26 Mar 2016 14:04:31 +0100 Subject: [PATCH 77/95] Bring examples to new notation --- example-sexp.lisp | 12 +++++------- example-symbol-table.lisp | 12 ++++++------ example-very-context-sensitive.lisp | 8 ++++---- 3 files changed, 15 insertions(+), 17 deletions(-) diff --git a/example-sexp.lisp b/example-sexp.lisp index 37f3653..fd2eea7 100644 --- a/example-sexp.lisp +++ b/example-sexp.lisp @@ -7,8 +7,6 @@ (in-package :sexp-grammar) -(enable-read-macro-tokens) - ;;; A semantic predicate for filtering out double quotes. (defun not-doublequote (char) @@ -29,7 +27,7 @@ (defrule string-char () (|| (pred #'not-doublequote character) - (list #\\ #\"))) + (list (v #\\) (v #\")))) ;;; Here we go: an S-expression is either a list or an atom, with possibly leading whitespace. @@ -40,15 +38,15 @@ (defrule magic () (if (eq * :use-magic) - (progn "foobar" + (progn (v "foobar") :magic) (fail-parse "No room for magic in this world"))) (defrule list () - #\( - (let ((res `(,sexp ,. (times sexp)))) + (v #\() + (let ((res `(,(v sexp) ,. (times sexp)))) (? whitespace) - #\) + (v #\)) res)) (defrule atom () diff --git a/example-symbol-table.lisp b/example-symbol-table.lisp index 464d63e..901b04f 100644 --- a/example-symbol-table.lisp +++ b/example-symbol-table.lisp @@ -44,13 +44,13 @@ (times (postimes (pred #'alphanumericp character)))) (defrule declaration () - (destructuring-bind (name colon type) (list name #\: type) + (destructuring-bind (name colon type) (list (v name) (v #\:) (v type)) (declare (ignore colon)) (setf (lookup name) (list name :type type)) (values))) (defrule use () - (let ((name name)) + (let ((name (v name))) (list :use (or (lookup name) (error "~@" name))))) @@ -59,14 +59,14 @@ (remove nil (postimes (|| scope declaration use)))) (defrule statement/ws () - (prog1 statement (? whitespace))) + (prog1 (v statement) (? whitespace))) (defrule scope () (let ((*symbol-table* (make-symbol-table *symbol-table*))) (list* :scope (apply #'append - (progm (progn #\{ (? whitespace)) - (* statement/ws) - (progn #\} (? whitespace))))))) + (progm (progn (v #\{) (? whitespace)) + (times statement/ws) + (progn (v #\}) (? whitespace))))))) (parse 'scope "{ a:int diff --git a/example-very-context-sensitive.lisp b/example-very-context-sensitive.lisp index 2010685..de54347 100644 --- a/example-very-context-sensitive.lisp +++ b/example-very-context-sensitive.lisp @@ -25,14 +25,14 @@ (character-ranges (#\0 #\9))) (defrule indent-spec-line () - (parse-integer (text (progm (progn spaces "|") + (parse-integer (text (progm (progn (v spaces) (v "|")) (postimes digit) - (progn "|" spaces #\newline))))) + (progn (v "|") (v spaces) (v #\newline)))))) (defrule indented-line () - (prog1 (text (make-string indented-spaces :initial-element #\space) + (prog1 (text (make-string (v indented-spaces) :initial-element #\space) (times (!! #\newline))) - #\newline)) + (v #\newline))) (defun more-indented-block-p (explicit-block) (>= (caddr explicit-block) From 1ff729c4d2e8e6e5ca428299c37a897d44af1f97 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sat, 26 Mar 2016 14:33:37 +0100 Subject: [PATCH 78/95] Shorten readme --- README.md | 120 ++++++++++++++++++++---------------------------------- 1 file changed, 44 insertions(+), 76 deletions(-) diff --git a/README.md b/README.md index 4b8218b..5e1f4e6 100644 --- a/README.md +++ b/README.md @@ -1,65 +1,23 @@ ESRAP-LIQUID ============ -Why shouldn't I use full Common Lisp while defining packrat parser rules? +MAJOR API CHANGE IN VERSIONS 2.*: we no longer use codewalker, hence rule definitions +now compile much faster. The price to pay is that sometimes you need to specify +manually, that something is a sub-rule (see V-macrolet). -It originated as a fork of ESRAP by Nikodemus Siivola (https://github.com/nikodemus/esrap), -but I quickly realized, that changes I wanted to make are so numerous, that in fact -it should be a separate project. +Packrat parser generator, with possibility to use full Common Lisp when defining parsing rules. -Original idea is in this article: +It started as a fork of ESRAP by Nikodemus Siivola (https://github.com/nikodemus/esrap), +which is a DSL with (somewhat) more rigid syntax, but (as of now) nicer error reports. + +Original idea of a packrat parser generator is described in this article: * Bryan Ford, 2002, "Packrat Parsing: a Practical Linear Time Algorithm with Backtracking". http://pdos.csail.mit.edu/~baford/packrat/thesis/ -What I wanted to improve in ESRAP: - - add support of context-sensitive grammars (I was trying to implement parsing of YAML) - - specifically, when caching, context should be taken into considerations - - make interface for defining rules more flexible: - every now and then I needed a new feature of rule-defining DSL and it - required hacking of core ESRAP code - - like so many DSL-projects out there, ESRAP implemented its own codewalker, - and would *greatly* benfit from not doing so: - - so I wanted to somehow reuse CL codewalker - - in particular, this would allow definition of package-local rules and - switch from interpreter mode to compiler mode. Theoretically, this would - make thing faster. - -The adjective, which suits the most to what I wanted ESRAP to be is "liquid", -so I added it and started hacking... - -What I was able to do until now: - - full support of context sensitivity: you can 'register' variables, which store the context, - and their value is taken into account, while caching results - - full reuse of CL's codewalker. - Special ESRAP syntax, which makes it so convenient in the first place, - is achieved with help of CL-READ-MACRO-TOKENS library; - hence, you are abile to use *whole* CL, while defining rules - - definition of a rule is not split into separate syntactic part and semantic part - It gives more flexibility, but also more opportunities to write suboptimal code - (e.g. the costly semantic operations may be performed for discarded results) - - rules may depend on additional arguments - (for example, CHARACTER rule, which accepts character it should match to) - So, syntax of DEFRULE is now very close to syntax of DEFUN - - STREAMING!!! Currenly I'm teaching ESRAP-LIQUID to work with streams - (and in general to parse lazily) Hence, soon it will be possible to actually - implement Lisp-reader with it (i.e., concisely) - - debugging is done by setting *DEBUG* variable to T and recompiling the package. - After that every parse outputs to stdout a progress of parsing in nice indented way, - which helps to untangle even most complicated bugs - -What's not yet done: - - introspection features (description of a grammar) - - case-insensitive terminals - - friendly parsing error reports - -Here are some examples of use. For more examples, -see example-sexp.lisp, example-symbol-table.lisp, example-very-context-sensitive.lisp. -For more real-life examples see my YAML parser https://github.com/mabragor/cl-yaclyaml. -The parsing part uses ESRAP-LIQUID extensively, in particular, in ways different from -traditional ESRAP. +Examples: ```lisp ; plain characters match to precisely that character in text @@ -159,33 +117,41 @@ ESRAP-LIQUID> (parse '(? #\a) "a") ``` Other operators, defined by ESRAP-LIQUID, include: - - (character-ranges ranges) -- character ranges - - (& followed-by) -- does not consume - - (-> followed-by-not-gen) -- does not consume, produces NIL + - (character-ranges ranges) -- succeeds, when next character fits into specified ranges + - (& followed-by) -- parses subclause, then rewinds iterator back, like PEEK-CHAR, but with possibly more complex expressions + - (-> followed-by-not-gen) -- same as &, but produces NIL - (<- preceded-by-not-gen) -- succeeds, if preceeded by something of length 1, produces NIL - - (! not-followed-by) -- does not consume - - (pred #' expr) -- semantic parsing - - (most-full-parse &rest exprs) -- try to parse all subexpressions and choose the one than - consumed most - + - (! not-followed-by) -- an antipode of &, also rewinds iterator + - (pred #' expr) -- succeeds, if #' returns true + - (most-full-parse &rest exprs) -- try to parse all subexpressions and choose the longest one + - (v subexpr &rest args) -- syntactic sugar for DESCEND-WITH-RULE Typical idioms: ```lisp ; succeed, when all subexpressions succeed, return list of those subexpressions -ESRAP-LIQUID> (parse '(list #\a #\b #\c) "abc") +; Note that now you need to explicitly write (V ...) in order to indicate that +; character means "try to parse this character" +ESRAP-LIQUID> (parse '(list (v #\a) (v #\b) (v #\c)) "abc") (#\a #\b #\c) 3 ; succeed, when all subexpression succeed, return only last subexpression -ESRAP-LIQUID> (parse '(progn #\a #\b #\c) "abc") +ESRAP-LIQUID> (parse '(progn (v #\a) (v #\b) (v #\c)) "abc") #\c 3 ; succeed, when all subexpression succeed, return only first subexpression -ESRAP-LIQUID> (parse '(prog1 #\a #\b #\c) "abc") +ESRAP-LIQUID> (parse '(prog1 (v #\a) (v #\b) (v #\c)) "abc") #\a 3 ``` +For more examples, +see example-sexp.lisp, example-symbol-table.lisp, example-very-context-sensitive.lisp. +For more real-life examples see my YAML parser https://github.com/mabragor/cl-yaclyaml. +The parsing part uses ESRAP-LIQUID extensively, in particular, in ways different from +traditional ESRAP. + + Defining rules -------------- @@ -203,9 +169,9 @@ ESRAP-LIQUID> (parse 'foo+ "foofoofoo") ; simple arguments to rules are also possible ESRAP-LIQUID> (defrule foo-times (times) (times "foo" :exactly times)) -ESRAP-LIQUID> (parse '(descend-with-rule 'foo-times 3) "foofoofoo") +ESRAP-LIQUID> (parse '(v foo-times 3) "foofoofoo") ("foo" "foo" "foo") -ESRAP-LIQUID> (parse '(descend-with-rule 'foo-times 4) "foofoofoo") +ESRAP-LIQUID> (parse '(v foo-times 4) "foofoofoo") #. ``` @@ -220,8 +186,8 @@ but instead in local 'environment' variable. This way you may have several non-c of rules defined at the same time. -Capturing-variables -------------------- +Capturing-variables : CAP, RECAP, RECAP? +---------------------------------------- Analogously to capturing groups in regexps, it is possible to capture results of parsing of named rules, to aid destructuring. @@ -230,21 +196,24 @@ Example: instead of clumsy ```lisp (define-rule dressed-rule-clumsy () - (prog1 (progn "foo" "bar" "baz" - meat) - "rest1" "rest2" "rest3")) + (prog1 (progn (v "foo") (v "bar") (v "baz") + (v meat)) + (v "rest1") (v "rest2") (v "rest3"))) ``` you may write something like ```lisp (define-rule dressed-rule-elegant () - "foo" "bar" "baz" c!-1-meat "rest1" "rest2" "rest3" - c!-1) + (v "foo") (v "bar") (v "baz") (cap 1 meat) (v "rest1") (v "rest2") (v "rest3") + (recap 1)) ``` -I.e. result of parsing of rule with name MEAT is stored in variable C!-1, -which is later accessed. +I.e. result of parsing of rule with name MEAT is stashed with CAP macro and +then accessed using RECAP macro. + +Difference between RECAP and RECAP? is that while the former fails parsing if +the requested key was not captured, the latter just produces NIL. See tests for examples of usage. Also see CL-MIZAR parsing.lisp, where this is used a lot. @@ -253,9 +222,8 @@ Also see CL-MIZAR parsing.lisp, where this is used a lot. Streaming --------- -Now I made critical morphing of the code, such that it is now usable to -parse not only strings of fixed length, but also streams and, in general, -iterators of tokens. +Now I made critical morphing of the code. Now it can be used not only to parse strings, +but also streams and, in general, iterators of tokens. Here I understand iterators Pythonic style, i.e. they are classes with defined NEXT-ITER method (the __next__ method in Python), that throws From cd6e250eda6441c47b0eb67b6df2a4f1380a9b62 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sat, 26 Mar 2016 15:07:45 +0100 Subject: [PATCH 79/95] Add section on API change --- README.md | 50 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 48 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 5e1f4e6..bb2fe34 100644 --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ ESRAP-LIQUID MAJOR API CHANGE IN VERSIONS 2.*: we no longer use codewalker, hence rule definitions now compile much faster. The price to pay is that sometimes you need to specify -manually, that something is a sub-rule (see V-macrolet). +manually, that something is a sub-rule (see V-macrolet in source and section "API Change" in this README). Packrat parser generator, with possibility to use full Common Lisp when defining parsing rules. @@ -245,4 +245,50 @@ includes: - TeX lexer + TeX parser (yes, it should be convenient to work not only on iterators of chars, but also on iterators of arbitrary tokens) - combined TeX + Lisp reader - \ No newline at end of file + +API Change +---------- + +In versions 1.* of ESRAP-LIQUID, we used the following implicit conventions, when +defining rules: + - character literals (#\) were understood as "try to parse this character out of the stream" + - string literals ("something") were understood as "try to parse this string out of the stream" + - free variables were understood as "try to find ESRAP rule with this name and parse it out of the stream" + +These conventions are very handy when defining rules. However, the way they were implemented, +is not optimal: + - character- and string-literal conventions required a use of implementation-dependent CL-READ-MACRO-TOKENS, + to introduce special reader syntax (which excluded use of ESRAP-LIQUID on unsupported implementations) + - free-variable convention required use of a codewalker (HU.DWIM.WALKER was used). + While acceptable for small rule sets, when using ESRAP-LIQUID for large (like VHDL) rule sets, + compilation really took long time (couple of minutes) and a lot of memory (GIGABYTES!) + + +So now these conventions are not valid in the whole scope of DEFRULE, but only +inside special macrolets. This allowed not to depend on codewalker and on special reader conventions. +Now conventions are like this: + - special V macrolet (down-arrow-macrolet) is used to indicate, that here a descent into subrule is meant + ```lisp + (defrule foo () + ... + (v #\a) ; parse literal char #\a + (v "asdf") ; parse literal string "asdf" + (v sub-rule x) ; parse a sub-rule, giving it an argument X (optional) + ...) + ``` + - in a lot of places V-macrolet is implicitly assumed (in all macro, defined in ESRAP-LIQUID). + thus + ```lisp + (times #\a) ; will be correctly understood as "parse 0 or more characters 'A'" + ``` + but in CL-form PROGN (or LIST) we have to explicitly write V-macrolets + ```lisp + (progn (v a) (v b) (v c)) ; parse sub-rules a, b and c + (list (v d) (v e) f) ; parse sub-rules d and e, return variable f + ``` + +Thus, to make a transition of your ESRAP-LIQUID-using code to 2.* API, you need: + - go over all DEFRULE's and place V-macrolets in some places + - replace C!-vars (related to capturing) with CAP, RECAP, RECAP? macros (see above) + + From e8020d4b66d3841229171f40049f6115e3c89c69 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sat, 26 Mar 2016 19:20:27 +0100 Subject: [PATCH 80/95] Export MAYBE-WRAP-IN-DESCENT utility function --- src/package.lisp | 1 + 1 file changed, 1 insertion(+) diff --git a/src/package.lisp b/src/package.lisp index b7f715c..28c206c 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -19,4 +19,5 @@ #:parse #:text #:fail-parse #:fail-parse-format #:define-esrap-env #:in-esrap-env #:v #:cap #:recap #:recap? + #:maybe-wrap-in-descent )) From f1a782ac38c2bee15dba4cc1357dd7ac1265cdd9 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sat, 26 Mar 2016 19:22:43 +0100 Subject: [PATCH 81/95] Fix ESRAP-ENV definition --- src/esrap-env.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/esrap-env.lisp b/src/esrap-env.lisp index 5007177..fc8d06c 100644 --- a/src/esrap-env.lisp +++ b/src/esrap-env.lisp @@ -53,7 +53,7 @@ (,',(symbolicate "DEFINE-" symbol "-RULE") ,rule-name () ;; KLUDGE: probably, special reader syntax for defining rules ;; will not work here anyway - (pred #',pred-name t) + (pred #',pred-name 't) nil)))) plausible-contexts) (push ',context-var ,',(symbolicate symbol "-CONTEXTS")))) From 26e4df227ee0a86e549d70aa0c44164e8a5fc76a Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Mon, 28 Mar 2016 21:43:16 +0200 Subject: [PATCH 82/95] Accurately propagate cap values upwards --- src/macro.lisp | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/src/macro.lisp b/src/macro.lisp index db2ca0a..b9c9f1d 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -35,16 +35,19 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defun propagate-cap-stash-upwards (up-var down-var body) (with-gensyms (g!-vals g!-it) - `(let ((,g!-vals (multiple-value-list (progn ,@body)))) - (iter (for (key . val) in (car ,down-var)) - ;; (format t "Propagating ~a ~a ... " key val) - (let ((,g!-it (assoc key (car ,up-var)))) - (if ,g!-it - (progn ;; (format t "update old~%") - (setf (cdr ,g!-it) val)) - (progn ;; (format t "create new~%") - (push (cons key val) (car ,up-var)))))) - (values-list ,g!-vals))))) + (let ((meat `(iter (for (key . val) in (car ,down-var)) + ;; (format t "Propagating ~a ~a ... " key val) + (let ((,g!-it (assoc key (car ,up-var)))) + (if ,g!-it + (progn ;; (format t "update old~%") + (setf (cdr ,g!-it) val)) + (progn ;; (format t "create new~%") + (push (cons key val) (car ,up-var)))))))) + (if (not body) + `(progn ,meat nil) + `(let ((,g!-vals (multiple-value-list (progn ,@body)))) + ,meat + (values-list ,g!-vals))))))) (defmacro with-sub-cap-stash (&body body) `(with-fresh-cap-stash From 639f7863bc514766804b8404a2c37cfed6809cfd Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Tue, 29 Mar 2016 12:12:48 +0200 Subject: [PATCH 83/95] Add mainly-non-context --- README.md | 21 ++++++++++++++++----- src/esrap-env.lisp | 23 ++++++++++++++++++----- 2 files changed, 34 insertions(+), 10 deletions(-) diff --git a/README.md b/README.md index bb2fe34..263dcd5 100644 --- a/README.md +++ b/README.md @@ -178,12 +178,23 @@ ESRAP-LIQUID> (parse '(v foo-times 4) "foofoofoo") Defining esrap-environments --------------------------- -To be written, main macro are: DEFINE-ESRAP-ENV and IN-ESRAP-ENV -Grep tests in order to see basic usage. +Usually you don't want to mix parsing rules for different projects -- you want +a mechanism to scope your rules in some way. For that you can use DEFINE-ESRAP-ENV macro. + +```lisp +(define-esrap-env foobar) + +;; Now we can define rules in 'foobar' scope +(define-foobar-rule asdf () + ... ; rule definition here) +``` + +DEFINE-ESRAP-ENV has a MAINLY-NON-CONTEXT key. If it's T, then DEFINE-$(NAME)-RULE +expands into DEF-NOCONTEXT-RULE, rather than DEFRULE. +It's still possible to get context-sensitive rules by using DEFINE-C-$(NAME)-RULE. +Vice versa, if MAINLY-NON-CONTEXT key is NIL (default), then non-context-sensitive rules +can be defined using DEFINE-NC-$(NAME)-RULE. -The feature is needed, if you want to define rules not in global *RULES* variable (the default), -but instead in local 'environment' variable. This way you may have several non-colliding sets -of rules defined at the same time. Capturing-variables : CAP, RECAP, RECAP? diff --git a/src/esrap-env.lisp b/src/esrap-env.lisp index fc8d06c..790f169 100644 --- a/src/esrap-env.lisp +++ b/src/esrap-env.lisp @@ -20,7 +20,7 @@ (setf (gethash rule hash-table) (gethash rule *rules*))))) -(defmacro define-esrap-env (symbol) +(defmacro define-esrap-env (symbol &key mainly-non-context) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (defvar ,(symbolicate symbol "-RULES") (make-hash-table)) (install-common-rules ,(symbolicate symbol "-RULES")) @@ -31,10 +31,23 @@ (defmacro ,(symbolicate "WITH-" symbol "-CONTEXTS") (&body body) `(let ((esrap-liquid::contexts ,',(symbolicate symbol "-CONTEXTS"))) ,@body)) - (defmacro ,(symbolicate "DEFINE-" symbol "-RULE") (symbol args &body body) - `(,',(symbolicate "WITH-" symbol "-RULES") - (,',(symbolicate "WITH-" symbol "-CONTEXTS") - (defrule ,symbol ,args ,@body)))) + ,(if mainly-non-context + `(progn (defmacro ,(symbolicate "DEFINE-" symbol "-RULE") (symbol args &body body) + `(,',(symbolicate "WITH-" symbol "-RULES") + (,',(symbolicate "WITH-" symbol "-CONTEXTS") + (def-nocontext-rule ,symbol ,args ,@body)))) + (defmacro ,(symbolicate "DEFINE-C-" symbol "-RULE") (symbol args &body body) + `(,',(symbolicate "WITH-" symbol "-RULES") + (,',(symbolicate "WITH-" symbol "-CONTEXTS") + (defrule ,symbol ,args ,@body))))) + `(progn (defmacro ,(symbolicate "DEFINE-" symbol "-RULE") (symbol args &body body) + `(,',(symbolicate "WITH-" symbol "-RULES") + (,',(symbolicate "WITH-" symbol "-CONTEXTS") + (defrule ,symbol ,args ,@body)))) + (defmacro ,(symbolicate "DEFINE-NC-" symbol "-RULE") (symbol args &body body) + `(,',(symbolicate "WITH-" symbol "-RULES") + (,',(symbolicate "WITH-" symbol "-CONTEXTS") + (def-nocontext-rule ,symbol ,args ,@body)))))) (defmacro ,(symbolicate "REGISTER-" symbol "-CONTEXT") (context-var &rest plausible-contexts) `(progn (defparameter ,context-var ,(make-keyword (car plausible-contexts))) From e57a86a033d5f70a6285c104d3f3c0c317bda921 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Wed, 30 Mar 2016 14:41:44 +0200 Subject: [PATCH 84/95] Add test about hinting --- tests/rules.lisp | 9 +++++++++ tests/tests.lisp | 4 ++++ 2 files changed, 13 insertions(+) diff --git a/tests/rules.lisp b/tests/rules.lisp index a6950e0..704df41 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -270,3 +270,12 @@ (|| (list (v #\a) (v #\b) (v #\c)) (list (v #\d) (v #\e) (v #\f)))) +(defrule sample-hinting-rule (&optional hint) + (v #\a) + hint) + +(defrule sample-hint-calling-rule () + (list (v sample-hinting-rule) + (v sample-hinting-rule 'x) + (descend-with-rule 'sample-hinting-rule 'x) + (descend-with-rule 'sample-hinting-rule))) diff --git a/tests/tests.lisp b/tests/tests.lisp index 2889547..154542c 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -253,6 +253,10 @@ (times #\a :exactly 5))) "aaaaa")))) +(test hint-calling-rule + (is (equal '(nil x x nil) + (parse 'sample-hint-calling-rule "aaaa")))) + ;;; esrap-env ;; (test esrap-env-print-case From 2cbb5325b755b7c7b4ce4e9a3e809a98fa17e522 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Tue, 5 Apr 2016 13:24:37 +0200 Subject: [PATCH 85/95] Add parse-stream function --- src/esrap-env.lisp | 106 +++++++++++++++++++++++++-------------------- src/esrap.lisp | 9 ++++ src/iterators.lisp | 12 +++++ src/macro.lisp | 2 +- src/package.lisp | 2 +- tests/tests.lisp | 12 ++++- 6 files changed, 92 insertions(+), 51 deletions(-) diff --git a/src/esrap-env.lisp b/src/esrap-env.lisp index 790f169..7fb6671 100644 --- a/src/esrap-env.lisp +++ b/src/esrap-env.lisp @@ -6,13 +6,16 @@ (in-package :esrap-liquid) +(cl-interpol:enable-interpol-syntax) + (defmacro in-esrap-env (symbol) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro ,(intern "DEFINE-RULE") (symbol args &body body) - `(,',(if symbol - (symbolicate "DEFINE-" symbol "-RULE") - 'defrule) - ,symbol ,args ,@body)))) + (flet ((s (x) (symbolicate (string-upcase x)))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro ,(s "define-rule") (symbol args &body body) + `(,',(if symbol + (s #?"define-$(symbol)-rule") + 'defrule) + ,symbol ,args ,@body))))) (defun install-common-rules (hash-table) (let ((common-rules '(any-string character string eof sof any-token))) @@ -20,75 +23,84 @@ (setf (gethash rule hash-table) (gethash rule *rules*))))) + +(defun reintern-to-right-package (expression) + (if (and (consp expression) + (eql (car expression) 'quote) + (equal (length expression) 2) + (symbolp (cadr expression)) + (not (keywordp (cadr expression)))) + `(quote ,(intern (string (cadr expression)) + *package*)) + expression)) + + (defmacro define-esrap-env (symbol &key mainly-non-context) + (flet ((s (x) (symbolicate (string-upcase x)))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar ,(symbolicate symbol "-RULES") (make-hash-table)) - (install-common-rules ,(symbolicate symbol "-RULES")) - (defvar ,(symbolicate symbol "-CONTEXTS") nil)) - (defmacro ,(symbolicate "WITH-" symbol "-RULES") (&body body) - `(let ((esrap-liquid::*rules* ,',(symbolicate symbol "-RULES"))) + (defvar ,(s #?"$(symbol)-rules") (make-hash-table)) + (install-common-rules ,(s #?"$(symbol)-rules")) + (defvar ,(s #?"$(symbol)-contexts") nil)) + (defmacro ,(s #?"with-$(symbol)-rules") (&body body) + `(let ((esrap-liquid::*rules* ,',(s #?"$(symbol)-rules"))) ,@body)) - (defmacro ,(symbolicate "WITH-" symbol "-CONTEXTS") (&body body) - `(let ((esrap-liquid::contexts ,',(symbolicate symbol "-CONTEXTS"))) + (defmacro ,(s #?"with-$(symbol)-contexts") (&body body) + `(let ((esrap-liquid::contexts ,',(s #?"$(symbol)-contexts"))) ,@body)) ,(if mainly-non-context - `(progn (defmacro ,(symbolicate "DEFINE-" symbol "-RULE") (symbol args &body body) - `(,',(symbolicate "WITH-" symbol "-RULES") - (,',(symbolicate "WITH-" symbol "-CONTEXTS") + `(progn (defmacro ,(s #?"define-$(symbol)-rule") (symbol args &body body) + `(,',(s #?"with-$(symbol)-rules") + (,',(s #?"with-$(symbol)-contexts") (def-nocontext-rule ,symbol ,args ,@body)))) - (defmacro ,(symbolicate "DEFINE-C-" symbol "-RULE") (symbol args &body body) - `(,',(symbolicate "WITH-" symbol "-RULES") - (,',(symbolicate "WITH-" symbol "-CONTEXTS") + (defmacro ,(s #?"define-c-$(symbol)-rule") (symbol args &body body) + `(,',(s #?"with-$(symbol)-rules") + (,',(s #?"with-$(symbol)-contexts") (defrule ,symbol ,args ,@body))))) - `(progn (defmacro ,(symbolicate "DEFINE-" symbol "-RULE") (symbol args &body body) - `(,',(symbolicate "WITH-" symbol "-RULES") - (,',(symbolicate "WITH-" symbol "-CONTEXTS") + `(progn (defmacro ,(s #?"define-$(symbol)-rule") (symbol args &body body) + `(,',(s #?"with-$(symbol)-rules") + (,',(s #?"with-$(symbol)-contexts") (defrule ,symbol ,args ,@body)))) - (defmacro ,(symbolicate "DEFINE-NC-" symbol "-RULE") (symbol args &body body) - `(,',(symbolicate "WITH-" symbol "-RULES") - (,',(symbolicate "WITH-" symbol "-CONTEXTS") + (defmacro ,(s #?"define-nc-$(symbol)-rule") (symbol args &body body) + `(,',(s #?"with-$(symbol)-rules") + (,',(s #?"with-$(symbol)-contexts") (def-nocontext-rule ,symbol ,args ,@body)))))) - (defmacro ,(symbolicate "REGISTER-" symbol "-CONTEXT") + (defmacro ,(s #?"register-$(symbol)-context") (context-var &rest plausible-contexts) `(progn (defparameter ,context-var ,(make-keyword (car plausible-contexts))) ,@(mapcar (lambda (context-name) - (let ((pred-name (symbolicate context-name - "-" - context-var - "-P")) - (rule-name (symbolicate context-name - "-" - context-var))) + (let ((pred-name (s #?"$(context-name)-$(context-var)-p")) + (rule-name (s #?"$(context-name)-$(context-var)"))) `(progn (defun ,pred-name (x) (declare (ignore x)) (equal ,context-var ,(make-keyword context-name))) - (,',(symbolicate "DEFINE-" symbol "-RULE") ,rule-name () + (,',(s #?"define-$(symbol)-rule") ,rule-name () ;; KLUDGE: probably, special reader syntax for defining rules ;; will not work here anyway (pred #',pred-name 't) nil)))) plausible-contexts) - (push ',context-var ,',(symbolicate symbol "-CONTEXTS")))) - (defmacro ,(symbolicate symbol "-PARSE") + (push ',context-var ,',(s #?"$(symbol)-contexts")))) + (defmacro ,(s #?"$(symbol)-parse") (expression text &key (start nil start-p) (end nil end-p) (junk-allowed nil junk-allowed-p)) - `(,',(symbolicate "WITH-" symbol "-RULES") - (,',(symbolicate "WITH-" symbol "-CONTEXTS") - (parse ,(if (and (consp expression) - (eql (car expression) 'quote) - (equal (length expression) 2) - (symbolp (cadr expression)) - (not (keywordp (cadr expression)))) - `',(intern (string (cadr expression)) - ',*package*) - expression) + `(,',(s #?"with-$(symbol)-rules") + (,',(s #?"with-$(symbol)-contexts") + (parse ,(reintern-to-right-package expression) ,text ,@(if start-p `(:start ,start)) ,@(if end-p `(:end ,end)) ,@(if junk-allowed-p - `(:junk-allowed ,junk-allowed)))))))) + `(:junk-allowed ,junk-allowed)))))) + (defmacro ,(s #?"$(symbol)-parse-stream") (expression stream &key (junk-allowed nil junk-allowed-p)) + `(,',(s #?"with-$(symbol)-rules") + (,',(s #?"with-$(symbol)-contexts") + (parse-stream ,(reintern-to-right-package expression) + ,stream + ,@(if junk-allowed-p + `(:junk-allowed ,junk-allowed))))))))) + diff --git a/src/esrap.lisp b/src/esrap.lisp index b2268b6..847e374 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -45,11 +45,20 @@ (defun mk-esrap-iter-from-string (str start end) (mk-cache-iter (mk-string-iter (subseq str start end)))) +(defun mk-esrap-iter-from-stream (stream) + (mk-cache-iter (mk-stream-iter stream))) + + (defun parse (expression text &key (start 0) end junk-allowed) "Parses TEXT using EXPRESSION from START to END. Incomplete parses are allowed only if JUNK-ALLOWED is true." (parse-token-iter expression (mk-esrap-iter-from-string text start end) :junk-allowed junk-allowed)) +(defun parse-stream (expression stream &key junk-allowed) + "Parses STREAM using EXPRESSION. Incomplete parses are allowed if JUNK-ALLOWED is true." + (parse-token-iter expression (mk-esrap-iter-from-stream stream) :junk-allowed junk-allowed)) + + (defmacro character-ranges (&rest char-specs) (with-gensyms (g!-char) (macrolet ((fail () diff --git a/src/iterators.lisp b/src/iterators.lisp index d135955..7dff8e8 100644 --- a/src/iterators.lisp +++ b/src/iterators.lisp @@ -87,9 +87,16 @@ ((pos :initform 0 :initarg :start) (str :initarg :string :initform ""))) +(defclass stream-iter () + ((stream :initarg :stream :initform (error "STEAM is required argument")))) + + (defun mk-string-iter (string &key (start 0)) (make-instance 'string-iter :string string :start start)) +(defun mk-stream-iter (stream) + (make-instance 'stream-iter :stream stream)) + (defmethod next-iter ((iter string-iter)) (with-slots (str pos) iter (if (equal pos (length str)) @@ -98,6 +105,11 @@ (incf pos) char)))) +(defmethod next-iter ((iter stream-iter)) + (with-slots (stream) iter + (or (read-char stream nil nil nil) + (error 'stop-iteration)))) + (defclass cache-iterator () ((cached-vals) (cached-pos :initform 0) diff --git a/src/macro.lisp b/src/macro.lisp index b9c9f1d..80325b2 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -81,7 +81,7 @@ (fail-parse-format "Key ~a is not captured (unbound)." ,key)))))) (recap? (key) `(handler-case (recap ,key) - (simple-esrap-error (e) nil)))) + (simple-esrap-error () nil)))) ,body)) (eval-when (:compile-toplevel :load-toplevel :execute) diff --git a/src/package.lisp b/src/package.lisp index 28c206c..46389dc 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -16,7 +16,7 @@ #:register-context #:concat #:defrule #:descend-with-rule #:any-string #:character #:string #:|| - #:parse #:text #:fail-parse #:fail-parse-format + #:parse #:parse-stream #:text #:fail-parse #:fail-parse-format #:define-esrap-env #:in-esrap-env #:v #:cap #:recap #:recap? #:maybe-wrap-in-descent diff --git a/tests/tests.lisp b/tests/tests.lisp index 154542c..5328ffb 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -194,8 +194,13 @@ (test esrap-env (is (equal "foo" (foo-parse 'abracadabra ""))) (is (equal "bar" (bar-parse 'abracadabra ""))) + (is (equal "foo" (foo-parse-stream 'abracadabra (make-string-input-stream "")))) + (is (equal "bar" (bar-parse-stream 'abracadabra (make-string-input-stream "")))) (signals (esrap-liquid::simple-error) - (parse 'abracadabra ""))) + (parse 'abracadabra "")) + (signals (esrap-liquid::simple-error) + (parse-stream 'abracadabra (make-string-input-stream ""))) + ) (test rule-closures (is (equal :a (parse 'closure-rule "a"))) @@ -251,7 +256,10 @@ (test most-full-parse (is (equal "aaaaa" (parse '(text (most-full-parse (times #\a :exactly 3) (times #\a :exactly 5))) - "aaaaa")))) + "aaaaa"))) + (is (equal "aaaaa" (parse-stream '(text (most-full-parse (times #\a :exactly 3) + (times #\a :exactly 5))) + (make-string-input-stream "aaaaa"))))) (test hint-calling-rule (is (equal '(nil x x nil) From c7732cf087aada813c32925b5153c7b4dd96d5cb Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Tue, 5 Apr 2016 13:37:16 +0200 Subject: [PATCH 86/95] Write about parse-stream in readme --- README.md | 52 ++++++++++++++++++++++++++++++++-------------------- 1 file changed, 32 insertions(+), 20 deletions(-) diff --git a/README.md b/README.md index 263dcd5..c7d604d 100644 --- a/README.md +++ b/README.md @@ -17,6 +17,8 @@ Original idea of a packrat parser generator is described in this article: http://pdos.csail.mit.edu/~baford/packrat/thesis/ +Operates *both* on strings and streams -- see section "Streaming" below. + Examples: ```lisp @@ -233,29 +235,39 @@ Also see CL-MIZAR parsing.lisp, where this is used a lot. Streaming --------- -Now I made critical morphing of the code. Now it can be used not only to parse strings, -but also streams and, in general, iterators of tokens. +It's possible to parse both strings and streams. Main function for parsing streams +is PARSE-STREAM. + +Example of usage: +```lisp +(parse-stream 'some-rule (make-string-input-stream "foobar") :junk-allowed t) +``` -Here I understand iterators Pythonic style, i.e. they are classes with defined -NEXT-ITER method (the __next__ method in Python), that throws -stop-iteration error (the StopIteration exception in Python) when there are +In general, both PARSE and PARSE-STREAMS are just wrappers around more +general PARSE-TOKEN-ITER -- which accepts an iterator of tokens. +Here, iterators are implemented "pythonic way", i.e. they are classes with +NEXT-ITER method (the __next__ method in Python), that throw +STOP-ITERATION condition (the StopIteration exception in Python) when there are no more values. -Now the function PARSE (which accepts string) is just a wrapper around -more general function PARSE-TOKEN-ITER (which accepts iterator of tokens) - -This is only the stub of fantastic possibilities it opens, but the -hard part (change of architechture) is over and only cosmetics remain, which -includes: - - PARSE-STREAM function, which accepts stream - - MK-PARSING-ITER, creates iterator, which (lazily) parses the token stream - - this should not only parse with a fixed rule, but also with different - rule each time, and with supplied iterator of rules to parse in turn - - it should be *convenient* to implement - - Lisp reader - - TeX lexer + TeX parser (yes, it should be convenient to work not only - on iterators of chars, but also on iterators of arbitrary tokens) - - combined TeX + Lisp reader +Thus, if you want ESRAP-LIQUID to parse something other than string or stream, +just grep for how PARSE-TOKEN-ITER is used. + + Gotchas! + ======== + + -- Since Lisp streams only allow to unread one character, and ESRAP-LIQUID in general + does quite a lot of look-ahead, it's not safe to use a stream somewhere else after + it was fed to PARSE-STREAM (even when :junk-allowed is set to T). This is because + you don't know, what state the stream ends up in. + + +When you define esrap environment using DEFINE-ESRAP-ENV, say, like +```lisp +(define-esrap-env foo) +``` +you get both FOO-PARSE and FOO-PARSE-STREAM -- environment versions of main parsing functions. + API Change ---------- From 0edc73bcc89fe6a339cf7f64aabb8d9ad932a0aa Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Tue, 5 Apr 2016 14:00:23 +0200 Subject: [PATCH 87/95] More tests for correct esrap-env --- src/esrap-env.lisp | 39 ++++++++++++++++++++------------------- tests/macro.lisp | 2 ++ tests/package.lisp | 8 ++++++++ tests/rules.lisp | 8 ++++++++ tests/tests.lisp | 6 ++++++ 5 files changed, 44 insertions(+), 19 deletions(-) diff --git a/src/esrap-env.lisp b/src/esrap-env.lisp index 7fb6671..2e80e08 100644 --- a/src/esrap-env.lisp +++ b/src/esrap-env.lisp @@ -24,14 +24,14 @@ (gethash rule *rules*))))) -(defun reintern-to-right-package (expression) +(defun reintern-to-right-package (expression package) (if (and (consp expression) (eql (car expression) 'quote) (equal (length expression) 2) (symbolp (cadr expression)) (not (keywordp (cadr expression)))) `(quote ,(intern (string (cadr expression)) - *package*)) + package)) expression)) @@ -66,28 +66,29 @@ (def-nocontext-rule ,symbol ,args ,@body)))))) (defmacro ,(s #?"register-$(symbol)-context") (context-var &rest plausible-contexts) - `(progn (defparameter ,context-var ,(make-keyword (car plausible-contexts))) - ,@(mapcar (lambda (context-name) - (let ((pred-name (s #?"$(context-name)-$(context-var)-p")) - (rule-name (s #?"$(context-name)-$(context-var)"))) - `(progn - (defun ,pred-name (x) - (declare (ignore x)) - (equal ,context-var ,(make-keyword context-name))) - (,',(s #?"define-$(symbol)-rule") ,rule-name () - ;; KLUDGE: probably, special reader syntax for defining rules - ;; will not work here anyway - (pred #',pred-name 't) - nil)))) - plausible-contexts) - (push ',context-var ,',(s #?"$(symbol)-contexts")))) + (flet ((s (x) (symbolicate (string-upcase x)))) + `(progn (defparameter ,context-var ,(make-keyword (car plausible-contexts))) + ,@(mapcar (lambda (context-name) + (let ((pred-name (s #?"$(context-name)-$(context-var)-p")) + (rule-name (s #?"$(context-name)-$(context-var)"))) + `(progn + (defun ,pred-name (x) + (declare (ignore x)) + (equal ,context-var ,(make-keyword context-name))) + (,',(s #?"define-$(symbol)-rule") ,rule-name () + ;; KLUDGE: probably, special reader syntax for defining rules + ;; will not work here anyway + (pred #',pred-name 't) + nil)))) + plausible-contexts) + (push ',context-var ,',(s #?"$(symbol)-contexts"))))) (defmacro ,(s #?"$(symbol)-parse") (expression text &key (start nil start-p) (end nil end-p) (junk-allowed nil junk-allowed-p)) `(,',(s #?"with-$(symbol)-rules") (,',(s #?"with-$(symbol)-contexts") - (parse ,(reintern-to-right-package expression) + (parse ,(reintern-to-right-package expression ,*package*) ,text ,@(if start-p `(:start ,start)) ,@(if end-p `(:end ,end)) @@ -96,7 +97,7 @@ (defmacro ,(s #?"$(symbol)-parse-stream") (expression stream &key (junk-allowed nil junk-allowed-p)) `(,',(s #?"with-$(symbol)-rules") (,',(s #?"with-$(symbol)-contexts") - (parse-stream ,(reintern-to-right-package expression) + (parse-stream ,(reintern-to-right-package expression ,*package*) ,stream ,@(if junk-allowed-p `(:junk-allowed ,junk-allowed))))))))) diff --git a/tests/macro.lisp b/tests/macro.lisp index 21c54c6..97a8ed0 100644 --- a/tests/macro.lisp +++ b/tests/macro.lisp @@ -9,3 +9,5 @@ ;; (setf *print-case* :downcase) ;; (register-foo-context foo-context-1 quux) ;; (setf *print-case* *old-print-case*)) + +(register-foo-context foo-context-1 quux) diff --git a/tests/package.lisp b/tests/package.lisp index 0baee82..e85be8a 100644 --- a/tests/package.lisp +++ b/tests/package.lisp @@ -7,11 +7,19 @@ (in-package :cl-user) +;; package to test importing rules from other packages +(defpackage :esrap-liquid-tests-other + (:use #:alexandria #:cl #:esrap-liquid #:fiveam #:iterate) + (:shadowing-import-from #:esrap-liquid #:! #:!!) + (:export #:quux-parse)) + (defpackage :esrap-liquid-tests (:use #:alexandria #:cl #:esrap-liquid #:fiveam #:iterate) (:shadowing-import-from #:esrap-liquid #:! #:!!) + (:shadowing-import-from #:esrap-liquid-tests-other #:quux-parse) (:export #:run-tests)) + (in-package :esrap-liquid-tests) (defun run-tests () diff --git a/tests/rules.lisp b/tests/rules.lisp index 704df41..ae98a6f 100644 --- a/tests/rules.lisp +++ b/tests/rules.lisp @@ -279,3 +279,11 @@ (v sample-hinting-rule 'x) (descend-with-rule 'sample-hinting-rule 'x) (descend-with-rule 'sample-hinting-rule))) + +(in-package #:esrap-liquid-tests-other) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (define-esrap-env quux)) + +(define-quux-rule quux-rule () + (v "quux")) diff --git a/tests/tests.lisp b/tests/tests.lisp index 5328ffb..82cc99e 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -270,3 +270,9 @@ ;; (test esrap-env-print-case ;; (is (eq :quux foo-context-1)) ;; (is-true (find-symbol "QUUX-FOO-CONTEXT-1-P"))) + +(test parse-in-another-package + (is (equal "quux" (quux-parse 'quux-rule "quux")))) + + + From 0f156346b18935c1bec6e296c74c57aac870fd05 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Tue, 5 Apr 2016 17:47:33 +0200 Subject: [PATCH 88/95] First cut on more intelligible error reporting --- src/basic-rules.lisp | 2 +- src/conditions.lisp | 40 +++++++++++++++++++++++++--------------- src/esrap.lisp | 17 ++++++++++++----- src/macro.lisp | 21 ++++++++++++--------- src/memoization.lisp | 17 ++++++++--------- tests/tests.lisp | 2 +- 6 files changed, 59 insertions(+), 40 deletions(-) diff --git a/src/basic-rules.lisp b/src/basic-rules.lisp index f29e4d9..48268a1 100644 --- a/src/basic-rules.lisp +++ b/src/basic-rules.lisp @@ -16,7 +16,7 @@ (defun eof-p () (handler-case (descend-with-rule 'eof) - (simple-esrap-error () nil))) + (internal-esrap-error () nil))) (def-nocontext-rule sof () (if (start-of-iter-p the-iter) diff --git a/src/conditions.lisp b/src/conditions.lisp index e2e23d6..dc24667 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -93,31 +93,41 @@ the error occurred.")) ;; position)) ;; (format stream "~2& "))))) -(define-condition simple-esrap-error (esrap-error simple-condition) ()) +(define-condition simple-esrap-error (esrap-error simple-condition) + ((rule-stack :initarg :rule-stack :accessor rule-stack))) -(defmethod print-object :before ((condition simple-esrap-error) stream) - (apply #'format stream - (simple-condition-format-control condition) - (simple-condition-format-arguments condition))) +(define-condition internal-esrap-error (esrap-error) ()) -(declaim (ftype (function (t t t &rest t) (values nil &optional)) +(defmethod print-object :around ((condition simple-esrap-error) stream) + (with-slots (rule-stack position reason) condition + (format stream + "ESRAP-LIQUID parsing failed. +Rule-stack : (~{~a~^ ~}) +Position : ~a +Specific reason: ~a~%" rule-stack position reason))) + +(declaim (ftype (function (t t t t &rest t) (values nil &optional)) simple-esrap-error)) -(defun simple-esrap-error (position reason format-control &rest format-arguments) +(defun simple-esrap-error (rule-stack position reason) (error 'simple-esrap-error :text "" + :rule-stack rule-stack :position position - :reason reason - :format-control format-control - :format-arguments format-arguments)) + :reason reason)) (defmacro fail-parse-format (&optional (reason "No particular reason.") &rest args) - `(let ((formatted-reason (apply #'format `(nil ,,reason ,,@args)))) - (if-debug "fail: ~a P ~a L ~a" formatted-reason the-position the-length) - (simple-esrap-error (+ the-position the-length) formatted-reason ,reason ,@args))) + `(progn (when (>= (+ the-position the-length) max-failed-position) + (setf max-failed-position (+ the-position the-length) + max-rule-stack *rule-stack* + max-message (apply #'format `(nil ,,reason ,,@args)))) + (error 'internal-esrap-error))) (defmacro fail-parse (&optional (reason "No particular reason.")) - `(progn (if-debug "fail: ~a: P ~a L ~a" ,reason the-position the-length) - (simple-esrap-error (+ the-position the-length) ,reason ,reason))) + `(progn (when (>= the-position max-failed-position) + (setf max-failed-position the-position + max-rule-stack *rule-stack* + max-message ,reason)) + (error 'internal-esrap-error))) (define-condition left-recursion (esrap-error) ((nonterminal :initarg :nonterminal :initform nil :reader left-recursion-nonterminal) diff --git a/src/esrap.lisp b/src/esrap.lisp index 847e374..488c102 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -22,24 +22,31 @@ ,@body)) (remhash ',g!-rule *rules*))))) +(defparameter max-failed-position 0) +(defparameter max-rule-stack nil) +(defparameter max-message "") (defun parse-token-iter (expression token-iter &key junk-allowed) (let ((the-iter token-iter) (*cache* (make-cache)) (the-position 0) - (the-length 0)) + (the-length 0) + (max-failed-position 0) + (max-rule-stack nil) + (max-message "")) (tracing-init (with-tmp-rule (tmp-rule expression) (let ((result (handler-case (descend-with-rule tmp-rule) - (simple-esrap-error (e) + (internal-esrap-error () (if junk-allowed (values nil 0) - (error e)))))) + (simple-esrap-error max-rule-stack max-failed-position max-message)))))) (if-debug "after tmp-rule") (when (not junk-allowed) (handler-case (descend-with-rule 'eof) - (simple-esrap-error () - (fail-parse "Didnt make it to the end of the text")))) + (internal-esrap-error () + (simple-esrap-error nil (+ the-position the-length) + "Didnt make it to the end of the text")))) (values result the-length)))))) (defun mk-esrap-iter-from-string (str start end) diff --git a/src/macro.lisp b/src/macro.lisp index 80325b2..5c3a70f 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -8,14 +8,17 @@ (cl-interpol:enable-interpol-syntax) +(defvar *rule-stack* nil) + (defmacro descend-with-rule (o!-sym &rest args) (with-gensyms (g!-it g!-got) (once-only (o!-sym) `(multiple-value-bind (,g!-it ,g!-got) (gethash ,o!-sym *rules*) (if (not ,g!-got) (error "Undefined rule: ~s" ,o!-sym) - (tracing-level - (funcall ,g!-it ,@args))))))) + (let ((*rule-stack* (cons ,o!-sym *rule-stack*))) + (tracing-level + (funcall ,g!-it ,@args)))))))) (defmacro the-position-boundary (&body body) `(let* ((the-position (+ the-position the-length)) @@ -81,7 +84,7 @@ (fail-parse-format "Key ~a is not captured (unbound)." ,key)))))) (recap? (key) `(handler-case (recap ,key) - (simple-esrap-error () nil)))) + (internal-esrap-error () nil)))) ,body)) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -157,7 +160,7 @@ (let ((res (with-sub-cap-stash ,(maybe-wrap-in-descent clause)))) ;; (if-debug "|| pre-succeeding") (values res the-length))) - (simple-esrap-error (e) + (internal-esrap-error (e) (restore-iter-state) (push e ,g!-parse-errors)))))) clauses) @@ -184,7 +187,7 @@ (with-saved-iter-state (the-iter) (with-fresh-cap-stash (handler-case ,(maybe-wrap-in-descent clause) - (simple-esrap-error (e) + (internal-esrap-error (e) (restore-iter-state) (push e ,g!-parse-errors)) (:no-error (res) @@ -213,7 +216,7 @@ (the-position-boundary (with-saved-iter-state (the-iter) (handler-case (with-fresh-cap-stash ,(maybe-wrap-in-descent expr)) - (simple-esrap-error () + (internal-esrap-error () (restore-iter-state) nil) (:no-error (result) @@ -229,7 +232,7 @@ (the-position-boundary (with-saved-iter-state (the-iter) (handler-case (with-fresh-cap-stash ,(maybe-wrap-in-descent expr)) - (simple-esrap-error () + (internal-esrap-error () (restore-iter-state) nil) (:no-error (result) @@ -255,7 +258,7 @@ ;; (format t " succeeding ~s ~a~%" subexpr the-length) ;; (print-iter-state the-iter) (values subexpr the-length))) - (simple-esrap-error () + (internal-esrap-error () ;; (format t " failing~%") (restore-iter-state) (finish)))) @@ -304,7 +307,7 @@ (print-iter-state) (with-saved-iter-state (the-iter) (handler-case (with-sub-cap-stash ,(maybe-wrap-in-descent subexpr)) - (simple-esrap-error () + (internal-esrap-error () (restore-iter-state) (values nil nil)) (:no-error (result) (return-from ,g!-? (values result the-length))))))) diff --git a/src/memoization.lisp b/src/memoization.lisp index 87aa81a..831c99f 100644 --- a/src/memoization.lisp +++ b/src/memoization.lisp @@ -66,14 +66,13 @@ (collect `(,key . ,val)))) (defun failed-parse-p (e) - (typep e 'simple-esrap-error)) + (typep e 'internal-esrap-error)) (defmacro with-cached-result ((symbol &rest args) &body forms) - (with-gensyms (g!-cache g!-args g!-position g!-result) - `(let* ((,g!-cache *cache*) - (,g!-args (list ,@args)) + (with-gensyms (g!-args g!-position g!-result) + `(let* ((,g!-args (list ,@args)) (,g!-position (+ the-position the-length)) - (,g!-result (get-cached ',symbol ,g!-position ,g!-args ,g!-cache)) + (,g!-result (get-cached ',symbol ,g!-position ,g!-args *cache*)) (*nonterminal-stack* (cons ',symbol *nonterminal-stack*))) (cond ((eq :left-recursion ,g!-result) (error 'left-recursion @@ -92,18 +91,18 @@ (print-iter-state the-iter) ;; First mark this pair with :LEFT-RECURSION to detect left-recursion, ;; then compute the result and cache that. - (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) :left-recursion) + (setf (get-cached ',symbol ,g!-position ,g!-args *cache*) :left-recursion) (multiple-value-bind (result length) (handler-case (the-position-boundary (values (progn ,@forms) the-length)) - (simple-esrap-error (e) (values e :error))) + (internal-esrap-error (e) (values e :error))) ;; (if-debug "after evaluation anew ~a ~a" length the-length) ;; LENGTH is non-NIL only for successful parses - (cond ((eq :error length) (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) + (cond ((eq :error length) (setf (get-cached ',symbol ,g!-position ,g!-args *cache*) result) (error result)) ((null length) (error "For some reason, length is NIL in memoization")) - (t (setf (get-cached ',symbol ,g!-position ,g!-args ,g!-cache) + (t (setf (get-cached ',symbol ,g!-position ,g!-args *cache*) (cons result length)) (incf the-length length) (if-debug "after setting cache ~a" the-length) diff --git a/tests/tests.lisp b/tests/tests.lisp index 82cc99e..04d3fcb 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -222,7 +222,7 @@ (is (equal '("f" "f" "f" "f") (parse '(v f-opt-times 4) "ffff"))) (signals-esrap-error ("ffff" 3 ("Didnt make it to the end of the text")) (parse 'f-opt-times "ffff")) - (signals-esrap-error ("fff" 3 ("Greedy repetition failed")) + (signals-esrap-error ("fff" 3 ("EOF while trying to parse")) (parse '(v f-opt-times 4) "fff"))) (test recursive-capturing From 47e83aaff5d397b81a9b5d3ea7be609077aab107 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Tue, 5 Apr 2016 18:40:24 +0200 Subject: [PATCH 89/95] Add iter's last text --- src/conditions.lisp | 17 +++++++++-------- src/esrap.lisp | 29 ++++++++++++++++++++++++++--- tests/tests.lisp | 6 +++--- 3 files changed, 38 insertions(+), 14 deletions(-) diff --git a/src/conditions.lisp b/src/conditions.lisp index dc24667..5b44532 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -99,18 +99,19 @@ the error occurred.")) (define-condition internal-esrap-error (esrap-error) ()) (defmethod print-object :around ((condition simple-esrap-error) stream) - (with-slots (rule-stack position reason) condition + (with-slots (rule-stack position reason text) condition (format stream "ESRAP-LIQUID parsing failed. Rule-stack : (~{~a~^ ~}) Position : ~a -Specific reason: ~a~%" rule-stack position reason))) +Text right before : ~a +Specific reason: ~a~%" rule-stack position text reason))) -(declaim (ftype (function (t t t t &rest t) (values nil &optional)) - simple-esrap-error)) -(defun simple-esrap-error (rule-stack position reason) +;; (declaim (ftype (function (t t t t) (values nil &optional)) +;; simple-esrap-error)) +(defun simple-esrap-error (text rule-stack position reason) (error 'simple-esrap-error - :text "" + :text text :rule-stack rule-stack :position position :reason reason)) @@ -123,8 +124,8 @@ Specific reason: ~a~%" rule-stack position reason))) (error 'internal-esrap-error))) (defmacro fail-parse (&optional (reason "No particular reason.")) - `(progn (when (>= the-position max-failed-position) - (setf max-failed-position the-position + `(progn (when (>= (+ the-position the-length) max-failed-position) + (setf max-failed-position (+ the-position the-length) max-rule-stack *rule-stack* max-message ,reason)) (error 'internal-esrap-error))) diff --git a/src/esrap.lisp b/src/esrap.lisp index 488c102..64c18a5 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -26,6 +26,26 @@ (defparameter max-rule-stack nil) (defparameter max-message "") +(defun iter-last-text (position) + (if (zerop position) + "" + (with-saved-iter-state (the-iter) + (unwind-protect + (with-slots (cached-vals cached-pos) the-iter + (with-slots (vector start-pointer) cached-vals + (text (if (<= 5 (- position start-pointer)) + (progn (rewind the-iter (- position 5)) + (iter (for i from 1 to 5) + (for x in-iter the-iter) + (collect x))) + (progn ;; (format t "start pointer : ~a~%" start-pointer) + (rewind the-iter start-pointer) + (iter (for i from 1 to (- position start-pointer)) + (for x in-iter the-iter) + (collect x))))))) + (restore-iter-state))))) + + (defun parse-token-iter (expression token-iter &key junk-allowed) (let ((the-iter token-iter) (*cache* (make-cache)) @@ -40,13 +60,16 @@ (internal-esrap-error () (if junk-allowed (values nil 0) - (simple-esrap-error max-rule-stack max-failed-position max-message)))))) + (simple-esrap-error + (iter-last-text max-failed-position) + max-rule-stack max-failed-position max-message)))))) (if-debug "after tmp-rule") (when (not junk-allowed) (handler-case (descend-with-rule 'eof) (internal-esrap-error () - (simple-esrap-error nil (+ the-position the-length) - "Didnt make it to the end of the text")))) + (simple-esrap-error + (iter-last-text (+ the-position the-length)) + nil (+ the-position the-length) "Didn't make it to the end of the text")))) (values result the-length)))))) (defun mk-esrap-iter-from-string (str start end) diff --git a/tests/tests.lisp b/tests/tests.lisp index 04d3fcb..402058f 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -74,7 +74,7 @@ (parse 'integer "")) (signals-esrap-error ("123foo" 3 ("Clause under non-consuming negation succeeded")) (parse 'integer "123foo")) - (signals-esrap-error ("1, " 1 ("Didnt make it to the end of the text")) + (signals-esrap-error ("1, " 1 ("Didn't make it to the end of the text")) (parse 'list-of-integers "1, "))) (test non-consuming-negation @@ -220,9 +220,9 @@ (test optional-rule-args (is (equal '("f" "f" "f") (parse 'f-opt-times "fff"))) (is (equal '("f" "f" "f" "f") (parse '(v f-opt-times 4) "ffff"))) - (signals-esrap-error ("ffff" 3 ("Didnt make it to the end of the text")) + (signals-esrap-error ("ffff" 3 ("Didn't make it to the end of the text")) (parse 'f-opt-times "ffff")) - (signals-esrap-error ("fff" 3 ("EOF while trying to parse")) + (signals-esrap-error ("fff" 3 ("Greedy repetition failed.")) (parse '(v f-opt-times 4) "fff"))) (test recursive-capturing From 99ccd2409e3dd7da141c969ebb367565e3d95055 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Wed, 6 Apr 2016 00:34:06 +0200 Subject: [PATCH 90/95] Add mood to log only essential fail-parses --- src/conditions.lisp | 10 ++++++---- src/esrap.lisp | 11 ++++++----- src/macro.lisp | 22 ++++++++++------------ 3 files changed, 22 insertions(+), 21 deletions(-) diff --git a/src/conditions.lisp b/src/conditions.lisp index 5b44532..53b5bf8 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -117,15 +117,17 @@ Specific reason: ~a~%" rule-stack position text reason))) :reason reason)) (defmacro fail-parse-format (&optional (reason "No particular reason.") &rest args) - `(progn (when (>= (+ the-position the-length) max-failed-position) - (setf max-failed-position (+ the-position the-length) + `(progn (when (and positive-mood + (>= the-position max-failed-position)) + (setf max-failed-position the-position max-rule-stack *rule-stack* max-message (apply #'format `(nil ,,reason ,,@args)))) (error 'internal-esrap-error))) (defmacro fail-parse (&optional (reason "No particular reason.")) - `(progn (when (>= (+ the-position the-length) max-failed-position) - (setf max-failed-position (+ the-position the-length) + `(progn (when (and positive-mood + (>= the-position max-failed-position)) + (setf max-failed-position the-position max-rule-stack *rule-stack* max-message ,reason)) (error 'internal-esrap-error))) diff --git a/src/esrap.lisp b/src/esrap.lisp index 64c18a5..2e167e8 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -22,10 +22,6 @@ ,@body)) (remhash ',g!-rule *rules*))))) -(defparameter max-failed-position 0) -(defparameter max-rule-stack nil) -(defparameter max-message "") - (defun iter-last-text (position) (if (zerop position) "" @@ -45,6 +41,10 @@ (collect x))))))) (restore-iter-state))))) +(defvar max-failed-position) +(defvar max-rule-stack) +(defvar max-message) +(defvar positive-mood) (defun parse-token-iter (expression token-iter &key junk-allowed) (let ((the-iter token-iter) @@ -53,7 +53,8 @@ (the-length 0) (max-failed-position 0) (max-rule-stack nil) - (max-message "")) + (max-message "") + (positive-mood t)) (tracing-init (with-tmp-rule (tmp-rule expression) (let ((result (handler-case (descend-with-rule tmp-rule) diff --git a/src/macro.lisp b/src/macro.lisp index 5c3a70f..cdf292b 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -165,10 +165,7 @@ (push e ,g!-parse-errors)))))) clauses) (if-debug "|| before failing P ~a L ~a" the-position the-length) - (fail-parse (joinl "~%" - (mapcar (lambda (x) - (slot-value x 'reason)) - (nreverse ,g!-parse-errors)))))) + (fail-parse "Optional parse failed"))) (if-debug "|| aftermath ~a ~a" the-length ,g!-the-length) (incf the-length ,g!-the-length) ,g!-result)))) @@ -200,10 +197,7 @@ (fast-forward the-iter length) (values res length)) (progn (if-debug "|| before failing P ~a L ~a" the-position the-length) - (fail-parse (joinl "~%" - (mapcar (lambda (x) - (slot-value x 'reason)) - (nreverse ,g!-parse-errors)))))))) + (fail-parse "MOST-FULL-PARSE failed."))))) (if-debug "MOST-FULL-PARSE aftermath ~a ~a" the-length ,g!-the-length) (incf the-length ,g!-the-length) ,g!-result)))) @@ -215,7 +209,8 @@ (if-debug "! P ~a L ~a" the-position the-length) (the-position-boundary (with-saved-iter-state (the-iter) - (handler-case (with-fresh-cap-stash ,(maybe-wrap-in-descent expr)) + (handler-case (let ((positive-mood nil)) + (with-fresh-cap-stash ,(maybe-wrap-in-descent expr))) (internal-esrap-error () (restore-iter-state) nil) @@ -231,7 +226,8 @@ (if-debug "!!") (the-position-boundary (with-saved-iter-state (the-iter) - (handler-case (with-fresh-cap-stash ,(maybe-wrap-in-descent expr)) + (handler-case (let ((positive-mood nil)) + (with-fresh-cap-stash ,(maybe-wrap-in-descent expr))) (internal-esrap-error () (restore-iter-state) nil) @@ -288,7 +284,8 @@ `(tracing-level (if-debug "PREDICATE") (with-sub-cap-stash - (let ((,g!-it ,(maybe-wrap-in-descent subexpr))) + (let ((,g!-it (let ((positive-mood nil)) + ,(maybe-wrap-in-descent subexpr)))) (if (funcall ,predicate ,g!-it) ,g!-it (fail-parse "Predicate test failed"))))))) @@ -306,7 +303,8 @@ (the-position-boundary (print-iter-state) (with-saved-iter-state (the-iter) - (handler-case (with-sub-cap-stash ,(maybe-wrap-in-descent subexpr)) + (handler-case (let ((positive-mood nil)) + (with-sub-cap-stash ,(maybe-wrap-in-descent subexpr))) (internal-esrap-error () (restore-iter-state) (values nil nil)) From 9311ea3795c8b292ebb2ae669925d5b091a21e2c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Breannd=C3=A1n=20=C3=93=20Nuall=C3=A1in?= Date: Sat, 18 Jun 2016 12:58:36 +0200 Subject: [PATCH 91/95] Fix typo in readme. --- README.md | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/README.md b/README.md index c7d604d..42dcf99 100644 --- a/README.md +++ b/README.md @@ -76,7 +76,7 @@ ESRAP-LIQUID> (parse '(|| #\a #\b) "a") #\a 1 ESRAP-LIQUID> (parse '(|| #\a #\b) "b") -#\a +#\b 1 ESRAP-LIQUID> (parse '(|| #\a #\b) "c") #. @@ -313,5 +313,3 @@ Now conventions are like this: Thus, to make a transition of your ESRAP-LIQUID-using code to 2.* API, you need: - go over all DEFRULE's and place V-macrolets in some places - replace C!-vars (related to capturing) with CAP, RECAP, RECAP? macros (see above) - - From acf4ea3253f0d85de583d7da05ab181b234c2880 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Mon, 27 Jun 2016 16:19:04 +0200 Subject: [PATCH 92/95] Add LIST-V, PROGN-V and PROG1-V macros --- README.md | 7 +++++++ src/macro.lisp | 13 +++++++++++++ src/package.lisp | 4 +++- tests/tests.lisp | 8 ++++++++ 4 files changed, 31 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index c7d604d..49d0284 100644 --- a/README.md +++ b/README.md @@ -127,6 +127,9 @@ Other operators, defined by ESRAP-LIQUID, include: - (pred #' expr) -- succeeds, if #' returns true - (most-full-parse &rest exprs) -- try to parse all subexpressions and choose the longest one - (v subexpr &rest args) -- syntactic sugar for DESCEND-WITH-RULE + - (progn-v &rest forms) -- like PROGN, but wraps its forms in DESCEND-WITH-RULE when needed + - (prog1-v &rest forms) -- like PROG1, but wraps its forms in DESCEND-WITH-RULE when needed + - (list-v &rest forms) -- like LIST, but wraps its forms in DESCEND-WITH-RULE when needed Typical idioms: @@ -309,6 +312,10 @@ Now conventions are like this: (progn (v a) (v b) (v c)) ; parse sub-rules a, b and c (list (v d) (v e) f) ; parse sub-rules d and e, return variable f ``` +Update: it turned out that in practice one most commonly uses V-macrolet +inside PROGN, LIST and PROG1 forms. So now ESRAP-LIQUID defines PROGN-V, LIST-V and PROG1-V +versions, which work exactly as their non-V analogs, but wrap their sub-forms +in DESCEND-WITH-RULE, where needed. Thus, to make a transition of your ESRAP-LIQUID-using code to 2.* API, you need: - go over all DEFRULE's and place V-macrolets in some places diff --git a/src/macro.lisp b/src/macro.lisp index cdf292b..6554075 100644 --- a/src/macro.lisp +++ b/src/macro.lisp @@ -294,6 +294,19 @@ "Prog Middle." `(progn ,(maybe-wrap-in-descent start) (prog1 ,(maybe-wrap-in-descent meat) ,(maybe-wrap-in-descent end)))) +(defmacro progn-v (&rest forms) + "PROGN with automatic descent wrapping." + `(progn ,@(mapcar #'maybe-wrap-in-descent forms))) + +(defmacro prog1-v (&rest forms) + "PROG1 with automatic descent wrapping." + `(prog1 ,@(mapcar #'maybe-wrap-in-descent forms))) + +(defmacro list-v (&rest args) + "LIST with automatic descent wrapping." + `(list ,@(mapcar #'maybe-wrap-in-descent args))) + + (defmacro ? (subexpr) (with-gensyms (g!-? g!-result g!-the-length) `(tracing-level diff --git a/src/package.lisp b/src/package.lisp index 46389dc..7bfb3f1 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -9,7 +9,9 @@ (defpackage :esrap-liquid (:use #:cl #:alexandria #:iterate) (:export - #:! #:? #:& #:~ #:<- #:-> #:!! #:times #:postimes #:pred #:progm #:cond-parse #:character-ranges + #:! #:? #:& #:~ #:<- #:-> #:!! #:times #:postimes #:pred + #:progm #:progn-v #:prog1-v #:list-v + #:cond-parse #:character-ranges #:most-full-parse #:match-start #:match-end #:literal-string #:literal-char diff --git a/tests/tests.lisp b/tests/tests.lisp index 402058f..bf956f4 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -133,6 +133,11 @@ (is (equal '(nil 0) (multiple-value-list (parse '(? (progn (v #\a) (v #\b))) "ac" :junk-allowed t)))) (is (equal '(nil 0) (multiple-value-list (parse '(? (progn (v #\a) (v #\b) (v #\c))) "abd" :junk-allowed t))))) +(test optional-test-progn-v + (is (equal '(#\b 2) (multiple-value-list (parse '(? (progn-v #\a #\b)) "ab")))) + (is (equal '(nil 0) (multiple-value-list (parse '(? (progn-v #\a #\b)) "ac" :junk-allowed t)))) + (is (equal '(nil 0) (multiple-value-list (parse '(? (progn-v #\a #\b #\c)) "abd" :junk-allowed t))))) + (test character-range-test (is (equal '(#\a #\b) (parse '(times (character-ranges (#\a #\z) #\-)) "ab" :junk-allowed t))) @@ -183,6 +188,9 @@ (test followed-by-not-gen (is (equal '("a" nil "b") (parse '(list (v "a") (-> "b") (v "b")) "ab")))) +(test followed-by-not-gen-list-v + (is (equal '("a" nil "b") (parse '(list-v "a" (-> "b") "b") "ab")))) + (test preceded-by-not-gen (is (equal '("a" nil "b") (parse '(list (v "a") (<- "a") (v "b")) "ab"))) (is (equal '("a" "b") (parse '(list (v "a") (|| (<- "b") (v "b"))) "ab"))) From 1eb9893affab1e8e98f45740e25814e91fab8fc8 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sun, 9 Oct 2016 16:21:30 +0200 Subject: [PATCH 93/95] Export PARSE-TOKEN-ITER in ESRAP-ENV --- README.md | 4 ++++ src/esrap-env.lisp | 19 ++++++++++++++----- src/esrap.lisp | 9 ++++++--- tests/tests.lisp | 5 ++++- 4 files changed, 28 insertions(+), 9 deletions(-) diff --git a/README.md b/README.md index 1448830..2b55efe 100644 --- a/README.md +++ b/README.md @@ -256,6 +256,10 @@ no more values. Thus, if you want ESRAP-LIQUID to parse something other than string or stream, just grep for how PARSE-TOKEN-ITER is used. +Change : PARSE-TOKEN-ITER now wraps the iterator into esrap caching iterator, +so you don't have to do it manually. +Also now ESRAP-ENV makes $(ENVNAME)-PARSE-TOKEN-ITER function accessible. + Gotchas! ======== diff --git a/src/esrap-env.lisp b/src/esrap-env.lisp index 2e80e08..1955ab0 100644 --- a/src/esrap-env.lisp +++ b/src/esrap-env.lisp @@ -96,11 +96,20 @@ `(:junk-allowed ,junk-allowed)))))) (defmacro ,(s #?"$(symbol)-parse-stream") (expression stream &key (junk-allowed nil junk-allowed-p)) `(,',(s #?"with-$(symbol)-rules") - (,',(s #?"with-$(symbol)-contexts") - (parse-stream ,(reintern-to-right-package expression ,*package*) - ,stream - ,@(if junk-allowed-p - `(:junk-allowed ,junk-allowed))))))))) + (,',(s #?"with-$(symbol)-contexts") + (parse-stream ,(reintern-to-right-package expression ,*package*) + ,stream + ,@(if junk-allowed-p + `(:junk-allowed ,junk-allowed)))))) + (defmacro ,(s #?"$(symbol)-parse-token-iter") (expression token-iter + &key (junk-allowed nil junk-allowed-p)) + `(,',(s #?"with-$(symbol)-rules") + (,',(s #?"with-$(symbol)-contexts") + (parse-token-iter ,(reintern-to-right-package expression ,*package*) + ,token-iter + ,@(if junk-allowed-p + `(:junk-allowed ,junk-allowed)))))) + ))) diff --git a/src/esrap.lisp b/src/esrap.lisp index 2e167e8..d5c82d8 100644 --- a/src/esrap.lisp +++ b/src/esrap.lisp @@ -46,7 +46,7 @@ (defvar max-message) (defvar positive-mood) -(defun parse-token-iter (expression token-iter &key junk-allowed) +(defun %parse-token-iter (expression token-iter &key junk-allowed) (let ((the-iter token-iter) (*cache* (make-cache)) (the-position 0) @@ -73,11 +73,14 @@ nil (+ the-position the-length) "Didn't make it to the end of the text")))) (values result the-length)))))) +(defun parse-token-iter (expression token-iter &key junk-allowed) + (%parse-token-iter expression (mk-cache-iter token-iter) :junk-allowed junk-allowed)) + (defun mk-esrap-iter-from-string (str start end) - (mk-cache-iter (mk-string-iter (subseq str start end)))) + (mk-string-iter (subseq str start end))) (defun mk-esrap-iter-from-stream (stream) - (mk-cache-iter (mk-stream-iter stream))) + (mk-stream-iter stream)) (defun parse (expression text &key (start 0) end junk-allowed) diff --git a/tests/tests.lisp b/tests/tests.lisp index bf956f4..648ba63 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -230,12 +230,15 @@ (is (equal '("f" "f" "f" "f") (parse '(v f-opt-times 4) "ffff"))) (signals-esrap-error ("ffff" 3 ("Didn't make it to the end of the text")) (parse 'f-opt-times "ffff")) - (signals-esrap-error ("fff" 3 ("Greedy repetition failed.")) + (signals-esrap-error ("fff" 3 ("EOF while trying to parse any string")) (parse '(v f-opt-times 4) "fff"))) (test recursive-capturing (is (equal '(#\1 #\2 #\3 #\4 #\5 nil) (parse 'recurcapturing "(1(2(3(4(5(a))))))")))) +(test token-iter + (is (equal :a (esrap-liquid::parse-token-iter 'closure-rule (esrap-liquid::mk-string-iter "a"))))) + ;;; String iterators From aed6a2741db3b0c9f304fe6544392440b28ae7e1 Mon Sep 17 00:00:00 2001 From: Alexandr Popolitov Date: Sun, 9 Oct 2016 17:28:13 +0200 Subject: [PATCH 94/95] Towards adding iterator extensions --- esrap-liquid.asd | 11 +++++++++++ src/iter-extensions.lisp | 25 +++++++++++++++++++++++++ src/iterators.lisp | 5 +++++ 3 files changed, 41 insertions(+) create mode 100644 src/iter-extensions.lisp diff --git a/esrap-liquid.asd b/esrap-liquid.asd index 5cec376..cc78e18 100644 --- a/esrap-liquid.asd +++ b/esrap-liquid.asd @@ -34,6 +34,17 @@ (:static-file "example-symbol-table.lisp") (:static-file "README"))) +(defsystem :esrap-liquid-iter + :version "0.1" ; odd minor version numbers are for unstable versions + :description "Extensions to ESRAP-LIQUID, using coroutines" + :licence "MIT" + :depends-on (#:alexandria #:iterate #:cl-itertools #:esrap-liquid) + :serial t + :components ((:module "src" + :pathname "src/" + :serial t + :components ((:file "iter-extensions"))))) + (defsystem :esrap-liquid-tests :description "Tests for ESRAP-LIQUID." :licence "GPL" diff --git a/src/iter-extensions.lisp b/src/iter-extensions.lisp new file mode 100644 index 0000000..4c5fd32 --- /dev/null +++ b/src/iter-extensions.lisp @@ -0,0 +1,25 @@ + +(in-package :esrap-liquid) + +(cl-itertools:defiter %mk-tokenizer (expression token-iter &key junk-allowed) + (let ((the-iter token-iter) + (*cache* (make-cache))) + (iter (while t) + (setf the-position 0 + the-length 0 + max-failed-position 0 + max-rule-stack nil + max-message "" + positive-mood t) + (tracing-init + (with-tmp-rule (tmp-rule expression) + (let ((result (handler-case (descend-with-rule tmp-rule) + (internal-esrap-error () + (if junk-allowed + (values nil 0) + (simple-esrap-error + (iter-last-text max-failed-position) + max-rule-stack max-failed-position max-message)))))) + (cl-itertools:yield (values result the-length))))) + (hard-shrink *cache* the-length) + (hard-shrink the-iter the-length)))) diff --git a/src/iterators.lisp b/src/iterators.lisp index 7dff8e8..6e4f504 100644 --- a/src/iterators.lisp +++ b/src/iterators.lisp @@ -204,3 +204,8 @@ (with-slots (start-pointer vector) cached-vals (if-debug " p ~a s ~a f ~a P ~a L ~a" cached-pos start-pointer (fill-pointer vector) the-position the-length)))) + +(defmethod hard-shrink ((obj cache-iterator) num-elts-discarded) + (with-slots (cached-vals cached-pos) obj + (decf cached-pos num-elts-discarded) + (hard-shrink cached-vals num-elts-discarded))) From 35f7855320fd7ba77f57cde663ad13d14ac3f281 Mon Sep 17 00:00:00 2001 From: popolit Date: Sun, 9 Oct 2016 20:45:00 +0200 Subject: [PATCH 95/95] First version of tokenizers using only hard-shrink --- esrap-liquid.asd | 14 ++--------- src/basic-rules.lisp | 5 +++- src/esrap-env.lisp | 8 +++++++ src/iter-extensions.lisp | 50 ++++++++++++++++++++++++++-------------- src/iterators.lisp | 16 ++++++++++--- src/memoization.lisp | 6 +++++ tests/tests.lisp | 18 ++++++++++++++- 7 files changed, 83 insertions(+), 34 deletions(-) diff --git a/esrap-liquid.asd b/esrap-liquid.asd index cc78e18..91da8b0 100644 --- a/esrap-liquid.asd +++ b/esrap-liquid.asd @@ -11,7 +11,7 @@ (in-package :esrap-liquid-system) (defsystem :esrap-liquid - :version "2.1" ; odd minor version numbers are for unstable versions + :version "2.3" ; odd minor version numbers are for unstable versions :description "A Packrat / Parsing Grammar / TDPL parser for Common Lisp." :licence "GPL" :depends-on (#:alexandria #:iterate #:cl-ppcre #:cl-interpol) @@ -29,22 +29,12 @@ (:file "esrap") (:file "basic-rules") (:file "esrap-env") + (:file "iter-extensions") )) (:static-file "example-sexp.lisp") (:static-file "example-symbol-table.lisp") (:static-file "README"))) -(defsystem :esrap-liquid-iter - :version "0.1" ; odd minor version numbers are for unstable versions - :description "Extensions to ESRAP-LIQUID, using coroutines" - :licence "MIT" - :depends-on (#:alexandria #:iterate #:cl-itertools #:esrap-liquid) - :serial t - :components ((:module "src" - :pathname "src/" - :serial t - :components ((:file "iter-extensions"))))) - (defsystem :esrap-liquid-tests :description "Tests for ESRAP-LIQUID." :licence "GPL" diff --git a/src/basic-rules.lisp b/src/basic-rules.lisp index 48268a1..ac812c6 100644 --- a/src/basic-rules.lisp +++ b/src/basic-rules.lisp @@ -29,7 +29,10 @@ (stop-iteration () (fail-parse "EOF while trying to parse any string of specified length."))))) (make-result (coerce pre-res 'string) length))) - + +(defun eof-error-p () + (cl-ppcre:all-matches-as-strings "^EOF" max-message)) + (defmacro any-string (length) `(descend-with-rule 'any-string ,length)) diff --git a/src/esrap-env.lisp b/src/esrap-env.lisp index 1955ab0..7fcbffd 100644 --- a/src/esrap-env.lisp +++ b/src/esrap-env.lisp @@ -109,6 +109,14 @@ ,token-iter ,@(if junk-allowed-p `(:junk-allowed ,junk-allowed)))))) + (defmacro ,(s #?"mk-$(symbol)-tokenizer") (expression token-iter + &key (junk-allowed nil junk-allowed-p)) + `(,',(s #?"with-$(symbol)-rules") + (,',(s #?"with-$(symbol)-contexts") + (mk-tokenizer ,(reintern-to-right-package expression ,*package*) + ,token-iter + ,@(if junk-allowed-p + `(:junk-allowed ,junk-allowed)))))) ))) diff --git a/src/iter-extensions.lisp b/src/iter-extensions.lisp index 4c5fd32..0c1146a 100644 --- a/src/iter-extensions.lisp +++ b/src/iter-extensions.lisp @@ -1,25 +1,41 @@ (in-package :esrap-liquid) -(cl-itertools:defiter %mk-tokenizer (expression token-iter &key junk-allowed) - (let ((the-iter token-iter) - (*cache* (make-cache))) - (iter (while t) - (setf the-position 0 - the-length 0 - max-failed-position 0 - max-rule-stack nil - max-message "" - positive-mood t) +(defun mk-tokenizer (expression token-iter &key junk-allowed) + (let ((my-cache (make-cache)) + (my-length nil) + (my-rules *rules*) + (my-contexts contexts)) + (lambda () + (when my-length + ;; (format t "My-length is nonnil, shrinking by: ~a~%" my-length) + ;; (format t "My-cache is: ~a~%" (print-esrap-cache my-cache)) + ;; (format t "My-iter is: ~a~%" (print-cache-iterator token-iter)) + (hard-shrink my-cache my-length) + ;; (format t "My-cache after shrinking is: ~a~%" (print-esrap-cache my-cache)) + (hard-shrink token-iter my-length) + ;; (format t "My-iter after shrinking is: ~a~%" (print-cache-iterator token-iter)) + ) + (let ((*cache* my-cache) + (the-iter token-iter) + (the-position 0) + (the-length 0) + (max-failed-position 0) + (max-rule-stack nil) + (max-message "") + (positive-mood t)) + (let ((*rules* my-rules) + (contexts my-contexts)) (tracing-init (with-tmp-rule (tmp-rule expression) (let ((result (handler-case (descend-with-rule tmp-rule) (internal-esrap-error () (if junk-allowed - (values nil 0) - (simple-esrap-error - (iter-last-text max-failed-position) - max-rule-stack max-failed-position max-message)))))) - (cl-itertools:yield (values result the-length))))) - (hard-shrink *cache* the-length) - (hard-shrink the-iter the-length)))) + (error 'stop-iteration) + (if (eof-error-p) + (error 'stop-iteration) + (simple-esrap-error + (iter-last-text max-failed-position) + max-rule-stack max-failed-position max-message))))))) + (setf my-length the-length) + (values result the-length))))))))) diff --git a/src/iterators.lisp b/src/iterators.lisp index 6e4f504..3d8a8f4 100644 --- a/src/iterators.lisp +++ b/src/iterators.lisp @@ -19,6 +19,10 @@ ((vector) (start-pointer :initform 0))) +(defun print-buffer-vector (vec) + (with-slots (vector start-pointer) vec + (format nil "[~a ~a]" start-pointer vector))) + (defmethod initialize-instance :after ((this buffer-vector) &key &allow-other-keys) (with-slots (vector) this (setf vector (make-array buffer-vector-start-length :adjustable t :fill-pointer t)))) @@ -49,6 +53,7 @@ (incf start-pointer num-elts-discarded))))) (defun calc-new-buffer-length (old-buffer-vector start-pointer) + "If we actually only use half of the buffer, shrink it in half." (let ((full-array-length (array-dimension old-buffer-vector 0)) (actual-length (- (fill-pointer old-buffer-vector) start-pointer))) (if (> actual-length (/ full-array-length 2)) @@ -59,9 +64,9 @@ (defmethod hard-shrink ((obj buffer-vector) (num-elts-discarded integer)) (with-slots (vector start-pointer) obj (let ((new-vector (make-array (calc-new-buffer-length vector start-pointer) :adjustable t :fill-pointer t))) - (iter (for i from 0 to (- (fill-pointer vector) start-pointer 1)) - (setf (aref new-vector i) (aref vector (+ start-pointer i)))) - (setf (fill-pointer new-vector) (- (fill-pointer vector) start-pointer) + (iter (for i from 0 to (- (fill-pointer vector) start-pointer 1 num-elts-discarded)) + (setf (aref new-vector i) (aref vector (+ start-pointer i num-elts-discarded)))) + (setf (fill-pointer new-vector) (- (fill-pointer vector) start-pointer num-elts-discarded) start-pointer 0 vector new-vector)))) @@ -115,6 +120,11 @@ (cached-pos :initform 0) (sub-iter :initform (error "Please, specify underlying iterator") :initarg :sub-iter))) +(defun print-cache-iterator (iter) + (with-slots (cached-pos cached-vals) iter + (format nil "[~a ~a]" cached-pos (print-buffer-vector cached-vals)))) + + (defmethod initialize-instance :after ((this cache-iterator) &key &allow-other-keys) (with-slots (cached-vals) this (setf cached-vals (make-instance 'buffer-vector)) diff --git a/src/memoization.lisp b/src/memoization.lisp index 831c99f..25da3c5 100644 --- a/src/memoization.lisp +++ b/src/memoization.lisp @@ -19,6 +19,12 @@ (defun make-cache () (make-instance 'esrap-cache)) +(defun print-esrap-cache (cache) + (format nil "[~a ~a]" (slot-value cache 'start-pos) + (mapcar (lambda (x) + (cons (car x) (hash->assoc (cdr x)))) + (hash->assoc (slot-value cache 'pos-hashtable))))) + (defgeneric get-cached (symbol position args cache) (:documentation "Accessor for cached parsing results.")) diff --git a/tests/tests.lisp b/tests/tests.lisp index 648ba63..02c26b1 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -285,5 +285,21 @@ (test parse-in-another-package (is (equal "quux" (quux-parse 'quux-rule "quux")))) - +(test mk-tokenizer + (let ((tokenizer (esrap-liquid::mk-tokenizer '(v character) + (esrap-liquid::mk-cache-iter + (esrap-liquid::mk-string-iter "asdf"))))) + (is (equal '(#\a #\s #\d #\f) (iter (for x next (handler-case (funcall tokenizer) + (esrap-liquid::stop-iteration () + (terminate)))) + (collect x))))) + (let ((tokenizer (esrap-liquid-tests-other::mk-quux-tokenizer + 'quux-rule + (esrap-liquid::mk-cache-iter + (esrap-liquid::mk-string-iter "quuxquuxquux"))))) + (is (equal '("quux" "quux" "quux") (iter (for x next (handler-case (funcall tokenizer) + (esrap-liquid::stop-iteration () + (terminate)))) + (collect x)))))) +