* module/ice-9/peg.scm: New file.
* module/Makefile.am: Add to build.
* doc/ref/Makefile.am:
* doc/ref/api-peg.texi:
* doc/ref/guile.texi: Add documentation for PEG parser.
* test-suite/Makefile.am:
* test-suite/tests/peg.bench:
* test-suite/tests/peg.test: Add tests, and a benchmark.
api-foreign.texi \
api-regex.texi \
api-lalr.texi \
+ api-peg.texi \
api-languages.texi \
api-evaluation.texi \
api-memory.texi \
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 2006, 2010
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node PEG Parsing
+@section PEG Parsing
+
+Parsing Expression Grammars (PEGs) are a way of specifying formal languages for text processing. They can be used either for matching (like regular expressions) or for building recursive descent parsers (like lex/yacc). Guile uses a superset of PEG syntax that allows more control over what information is preserved during parsing.
+
+Wikipedia has a clear and concise introduction to PEGs if you want to familiarize yourself with the syntax: @url{http://en.wikipedia.org/wiki/Parsing_expression_grammar}.
+
+The module works by compiling PEGs down to lambda expressions. These can either be stored in variables at compile-time by the define macros (@code{define-nonterm} and @code{define-grammar}) or calculated explicitly at runtime with the compile functions (@code{peg-sexp-compile} and @code{peg-string-compile}).
+
+They can then be used for either parsing (@code{peg-parse}) or matching (@code{peg-match}). For convenience, @code{peg-match} also takes pattern literals in case you want to inline a simple search (people often use regular expressions this way).
+
+The rest of this documentation consists of a syntax reference, an API reference, and a tutorial.
+
+@menu
+* PEG Syntax Reference::
+* PEG API Reference::
+* PEG Tutorial::
+@end menu
+
+@node PEG Syntax Reference
+@subsection PEG Syntax Reference
+
+@subsubheading Normal PEG Syntax:
+
+Format: @*
+Name @*
+Description @*
+String Syntax @*
+S-expression Syntax @*
+
+Sequence @code{a} @code{b}: @*
+Parses @code{a}. If this succeeds, continues to parse @code{b} from the end of the text parsed as @code{a}. Succeeds if both @code{a} and @code{b} succeed. @*
+@code{"a b"} @*
+@code{(and a b)} @*
+
+Ordered choice @code{a} @code{b}: @*
+Parses @code{a}. If this fails, backtracks and parses @code{b}. Succeeds if either @code{a} or @code{b} succeeds. @*
+@code{"a/b"} @*
+@code{(or a b)} @*
+
+Zero or more @code{a}: @*
+Parses @code{a} as many times in a row as it can, starting each @code{a} at the end of the text parsed by the previous @code{a}. Always succeeds. @*
+@code{"a*"} @*
+@code{(body lit a *)} @*
+
+One or more @code{a}: @*
+Parses @code{a} as many times in a row as it can, starting each @code{a} at the end of the text parsed by the previous @code{a}. Succeeds if at least one @code{a} was parsed. @*
+@code{"a+"} @*
+@code{(body lit a +)} @*
+
+Optional @code{a}: @*
+Tries to parse @code{a}. Succeeds if @code{a} succeeds. @*
+@code{"a?"} @*
+@code{(body lit a ?)} @*
+
+And predicate @code{a}: @*
+Makes sure it is possible to parse @code{a}, but does not actually parse it. Succeeds if @code{a} would succeed. @*
+@code{"&a"} @*
+@code{(body & a 1)} @*
+
+Not predicate @code{a}: @*
+Makes sure it is impossible to parse @code{a}, but does not actually parse it. Succeeds if @code{a} would fail. @*
+@code{"!a"} @*
+@code{(body ! a 1)} @*
+
+String literal @code{"abc"}: @*
+Parses the string @code{"abc"}. Succeeds if that parsing succeeds. @*
+@code{"'abc'"} @*
+@code{"abc"} @*
+
+Any character: @*
+Parses any single character. Succeeds unless there is no more text to be parsed. @*
+@code{"."} @*
+@code{peg-any} @*
+
+Character class @code{a} @code{b}: @*
+Alternative syntax for ``Ordered Choice @code{a} @code{b}'' if @code{a} and @code{b} are characters. @*
+@code{"[ab]"} @*
+@code{(or "a" "b")} @*
+
+Range of characters @code{a} to @code{z}: @*
+Parses any character falling between @code{a} and @code{z}. @*
+@code{"[a-z]"} @*
+@code{(range #\a #\z)} @*
+
+Example: @*
+@code{"(a !b / c &d*) 'e'+"} @*
+Would be:
+@lisp
+(and
+ (or
+ (and a (body ! b 1))
+ (and c (body & d *)))
+ (body lit "e" +))
+@end lisp
+
+@subsubheading Extended Syntax:
+There is some extra syntax for S-expressions.
+
+Format: @*
+Description @*
+S-expression syntax @*
+
+Ignore the text matching @code{a}: @*
+@code{(ignore a)} @*
+
+Capture the text matching @code{a}: @*
+@code{(capture a)} @*
+
+Embed the PEG pattern @code{a} using string syntax: @*
+@code{(peg a)} @*
+
+Example: @*
+@code{"!a / 'b'"} @*
+Would be:
+@lisp
+(or (peg "!a") "b")
+@end lisp
+
+@node PEG API Reference
+@subsection PEG API Reference
+
+@subsubheading Define Macros
+
+The most straightforward way to define a PEG is by using one of the define macros (both of these macroexpand into @code{define} expressions). These macros bind parsing functions to variables. These parsing functions may be invoked by @code{peg-parse} or @code{peg-match}, which return a PEG match record. Raw data can be retrieved from this record with the PEG match deconstructor functions. More complicated (and perhaps enlightening) examples can be found in the tutorial.
+
+@deffn {Scheme Macro} define-grammar peg-string
+Defines all the nonterminals in the PEG @var{peg-string}. More precisely, @code{define-grammar} takes a superset of PEGs. A normal PEG has a @code{<-} between the nonterminal and the pattern. @code{define-grammar} uses this symbol to determine what information it should propagate up the parse tree. The normal @code{<-} propagates the matched text up the parse tree, @code{<--} propagates the matched text up the parse tree tagged with the name of the nonterminal, and @code{<} discards that matched text and propagates nothing up the parse tree. Also, nonterminals may consist of any alphanumeric character or a ``-'' character (in normal PEGs nonterminals can only be alphabetic).
+
+For example, if we:
+@lisp
+(define-grammar
+ "as <- 'a'+
+bs <- 'b'+
+as-or-bs <- as/bs")
+(define-grammar
+ "as-tag <-- 'a'+
+bs-tag <-- 'b'+
+as-or-bs-tag <-- as-tag/bs-tag")
+@end lisp
+Then:
+@lisp
+(peg-parse as-or-bs "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: aa>
+(peg-parse as-or-bs-tag "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: (as-or-bs-tag (as-tag aa))>
+@end lisp
+
+Note that in doing this, we have bound 6 variables at the toplevel (@var{as}, @var{bs}, @var{as-or-bs}, @var{as-tag}, @var{bs-tag}, and @var{as-or-bs-tag}).
+@end deffn
+
+@deffn {Scheme Macro} define-nonterm name capture-type peg-sexp
+Defines a single nonterminal @var{name}. @var{capture-type} determines how much information is passed up the parse tree. @var{peg-sexp} is a PEG in S-expression form.
+
+Possible values for capture-type: @*
+@code{all}: passes the matched text up the parse tree tagged with the name of the nonterminal. @*
+@code{body}: passes the matched text up the parse tree. @*
+@code{none}: passes nothing up the parse tree.
+
+For Example, if we:
+@lisp
+(define-nonterm as body (body lit "a" +))
+(define-nonterm bs body (body lit "b" +))
+(define-nonterm as-or-bs body (or as bs))
+(define-nonterm as-tag all (body lit "a" +))
+(define-nonterm bs-tag all (body lit "b" +))
+(define-nonterm as-or-bs-tag all (or as-tag bs-tag))
+@end lisp
+Then:
+@lisp
+(peg-parse as-or-bs "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: aa>
+(peg-parse as-or-bs-tag "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: (as-or-bs-tag (as-tag aa))>
+@end lisp
+
+Note that in doing this, we have bound 6 variables at the toplevel (@var{as}, @var{bs}, @var{as-or-bs}, @var{as-tag}, @var{bs-tag}, and @var{as-or-bs-tag}).
+@end deffn
+
+These are macros, with all that entails. If you've built up a list at runtime and want to define a new PEG from it, you should e.g.:
+@lisp
+(define exp '(body lit "a" +))
+(eval `(define-nonterm as body ,exp) (interaction-environment))
+@end lisp
+The @code{eval} function has a bad reputation with regard to efficiency, but this is mostly because of the extra work that has to be done compiling the expressions, which has to be done anyway when compiling the PEGs at runtime.
+
+@subsubheading
+
+@subsubheading Compile Functions
+It is sometimes useful to be able to compile anonymous PEG patterns at runtime. These functions let you do that using either syntax.
+
+@deffn {Scheme Procedure} peg-string-compile peg-string capture-type
+Compiles the PEG pattern in @var{peg-string} propagating according to @var{capture-type} (capture-type can be any of the values from @code{define-nonterm}).
+@end deffn
+
+
+@deffn {Scheme Procedure} peg-sexp-compile peg-sexp capture-type
+Compiles the PEG pattern in @var{peg-sexp} propagating according to @var{capture-type} (capture-type can be any of the values from @code{define-nonterm}).
+@end deffn
+
+
+@subsubheading Parsing & Matching Functions
+
+For our purposes, ``parsing'' means parsing a string into a tree starting from the first character, while ``matching'' means searching through the string for a substring. In practice, the only difference between the two functions is that @code{peg-parse} gives up if it can't find a valid substring starting at index 0 and @code{peg-match} keeps looking. They are both equally capable of ``parsing'' and ``matching'' given those constraints.
+
+@deffn {Scheme Procedure} peg-parse nonterm string
+Parses @var{string} using the PEG stored in @var{nonterm}. If no match was found, @code{peg-parse} returns false. If a match was found, a PEG match record is returned.
+
+The @code{capture-type} argument to @code{define-nonterm} allows you to choose what information to hold on to while parsing. The options are: @*
+@code{all}: tag the matched text with the nonterminal @*
+@code{body}: just the matched text @*
+@code{none}: nothing @*
+
+@lisp
+(define-nonterm as all (body lit "a" +))
+(peg-parse as "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: (as aa)>
+
+(define-nonterm as body (body lit "a" +))
+(peg-parse as "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: aa>
+
+(define-nonterm as none (body lit "a" +))
+(peg-parse as "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: ()>
+
+(define-nonterm bs body (body lit "b" +))
+(peg-parse bs "aabbcc") @result{}
+#f
+@end lisp
+@end deffn
+
+@deffn {Scheme Macro} peg-match nonterm-or-peg string
+Searches through @var{string} looking for a matching subexpression. @var{nonterm-or-peg} can either be a nonterminal or a literal PEG pattern. When a literal PEG pattern is provided, @code{peg-match} works very similarly to the regular expression searches many hackers are used to. If no match was found, @code{peg-match} returns false. If a match was found, a PEG match record is returned.
+
+@lisp
+(define-nonterm as body (body lit "a" +))
+(peg-match as "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: aa>
+(peg-match (body lit "a" +) "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: aa>
+(peg-match "'a'+" "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: aa>
+
+(define-nonterm as all (body lit "a" +))
+(peg-match as "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: (as aa)>
+
+(define-nonterm bs body (body lit "b" +))
+(peg-match bs "aabbcc") @result{}
+#<peg start: 2 end: 4 string: aabbcc tree: bb>
+(peg-match (body lit "b" +) "aabbcc") @result{}
+#<peg start: 2 end: 4 string: aabbcc tree: bb>
+(peg-match "'b'+" "aabbcc") @result{}
+#<peg start: 2 end: 4 string: aabbcc tree: bb>
+
+(define-nonterm zs body (body lit "z" +))
+(peg-match zs "aabbcc") @result{}
+#f
+(peg-match (body lit "z" +) "aabbcc") @result{}
+#f
+(peg-match "'z'+" "aabbcc") @result{}
+#f
+@end lisp
+@end deffn
+
+@subsubheading PEG Match Records
+The @code{peg-parse} and @code{peg-match} functions both return PEG match records. Actual information can be extracted from these with the following functions.
+
+@deffn {Scheme Procedure} peg:string peg-match
+Returns the original string that was parsed in the creation of @code{peg-match}.
+@end deffn
+
+@deffn {Scheme Procedure} peg:start peg-match
+Returns the index of the first parsed character in the original string (from @code{peg:string}). If this is the same as @code{peg:end}, nothing was parsed.
+@end deffn
+
+@deffn {Scheme Procedure} peg:end peg-match
+Returns one more than the index of the last parsed character in the original string (from @code{peg:string}). If this is the same as @code{peg:start}, nothing was parsed.
+@end deffn
+
+@deffn {Scheme Procedure} peg:substring peg-match
+Returns the substring parsed by @code{peg-match}. This is equivalent to @code{(substring (peg:string peg-match) (peg:start peg-match) (peg:end peg-match))}.
+@end deffn
+
+@deffn {Scheme Procedure} peg:tree peg-match
+Returns the tree parsed by @code{peg-match}.
+@end deffn
+
+@deffn {Scheme Procedure} peg-record? peg-match
+Returns true if @code{peg-match} is a PEG match record, or false otherwise.
+@end deffn
+
+Example:
+@lisp
+(define-nonterm bs all (peg "'b'+"))
+
+(peg-match bs "aabbcc") @result{}
+#<peg start: 2 end: 4 string: aabbcc tree: (bs bb)>
+
+(let ((pm (peg-match bs "aabbcc")))
+ `((string ,(peg:string pm))
+ (start ,(peg:start pm))
+ (end ,(peg:end pm))
+ (substring ,(peg:substring pm))
+ (tree ,(peg:tree pm))
+ (record? ,(peg-record? pm)))) @result{}
+((string "aabbcc")
+ (start 2)
+ (end 4)
+ (substring "bb")
+ (tree (bs "bb"))
+ (record? #t))
+@end lisp
+
+@subsubheading Miscellaneous
+
+@deffn {Scheme Procedure} context-flatten tst lst
+Takes a predicate @var{tst} and a list @var{lst}. Flattens @var{lst} until all elements are either atoms or satisfy @var{tst}. If @var{lst} itself satisfies @var{tst}, @code{(list lst)} is returned (this is a flat list whose only element satisfies @var{tst}).
+
+@lisp
+(context-flatten (lambda (x) (and (number? (car x)) (= (car x) 1))) '(2 2 (1 1 (2 2)) (2 2 (1 1)))) @result{}
+(2 2 (1 1 (2 2)) 2 2 (1 1))
+(context-flatten (lambda (x) (and (number? (car x)) (= (car x) 1))) '(1 1 (1 1 (2 2)) (2 2 (1 1)))) @result{}
+((1 1 (1 1 (2 2)) (2 2 (1 1))))
+@end lisp
+
+If you're wondering why this is here, take a look at the tutorial.
+@end deffn
+
+@deffn {Scheme Procedure} keyword-flatten terms lst
+A less general form of @code{context-flatten}. Takes a list of terminal atoms @code{terms} and flattens @var{lst} until all elements are either atoms, or lists which have an atom from @code{terms} as their first element.
+@lisp
+(keyword-flatten '(a b) '(c a b (a c) (b c) (c (b a) (c a)))) @result{}
+(c a b (a c) (b c) c (b a) c a)
+@end lisp
+
+If you're wondering why this is here, take a look at the tutorial.
+@end deffn
+
+@node PEG Tutorial
+@subsection PEG Tutorial
+
+@subsubheading Parsing /etc/passwd
+This example will show how to parse /etc/passwd using PEGs.
+
+First we define an example /etc/passwd file:
+
+@lisp
+(define *etc-passwd*
+ "root:x:0:0:root:/root:/bin/bash
+daemon:x:1:1:daemon:/usr/sbin:/bin/sh
+bin:x:2:2:bin:/bin:/bin/sh
+sys:x:3:3:sys:/dev:/bin/sh
+nobody:x:65534:65534:nobody:/nonexistent:/bin/sh
+messagebus:x:103:107::/var/run/dbus:/bin/false
+")
+@end lisp
+
+As a first pass at this, we might want to have all the entries in /etc/passwd in a list.
+
+Doing this with string-based PEG syntax would look like this:
+@lisp
+(define-grammar
+ "passwd <- entry* !.
+entry <-- (! NL .)* NL*
+NL < '\n'")
+@end lisp
+A @code{passwd} file is 0 or more entries (@code{entry*}) until the end of the file (@code{!.} (@code{.} is any character, so @code{!.} means ``not anything'')). We want to capture the data in the nonterminal @code{passwd}, but not tag it with the name, so we use @code{<-}.
+An entry is a series of 0 or more characters that aren't newlines (@code{(! NL .)*}) followed by 0 or more newlines (@code{NL*}). We want to tag all the entries with @code{entry}, so we use @code{<--}.
+A newline is just a literal newline (@code{'\n'}). We don't want a bunch of newlines cluttering up the output, so we use @code{<} to throw away the captured data.
+
+Here is the same PEG defined using S-expressions:
+@lisp
+(define-nonterm passwd body (and (body lit entry *) (body ! peg-any 1)))
+(define-nonterm entry all (and (body lit (and (body ! NL 1) peg-any) *)
+ (body lit NL *)))
+(define-nonterm NL none "\n")
+@end lisp
+
+Obviously this is much more verbose. On the other hand, it's more explicit, and thus easier to build automatically. However, there are some tricks that make S-expressions easier to use in some cases. One is the @code{ignore} keyword; the string syntax has no way to say ``throw away this text'' except breaking it out into a separate nonterminal. For instance, to throw away the newlines we had to define @code{NL}. In the S-expression syntax, we could have simply written @code{(ignore "\n")}. Also, for the cases where string syntax is really much cleaner, the @code{peg} keyword can be used to embed string syntax in S-expression syntax. For instance, we could have written:
+@lisp
+(define-nonterm passwd body (peg "entry* !."))
+@end lisp
+
+However we define it, parsing @code{*etc-passwd*} with the @code{passwd} nonterminal yields the same results:
+@lisp
+(peg:tree (peg-parse passwd *etc-passwd*)) @result{}
+((entry "root:x:0:0:root:/root:/bin/bash")
+ (entry "daemon:x:1:1:daemon:/usr/sbin:/bin/sh")
+ (entry "bin:x:2:2:bin:/bin:/bin/sh")
+ (entry "sys:x:3:3:sys:/dev:/bin/sh")
+ (entry "nobody:x:65534:65534:nobody:/nonexistent:/bin/sh")
+ (entry "messagebus:x:103:107::/var/run/dbus:/bin/false"))
+@end lisp
+
+However, here is something to be wary of:
+@lisp
+(peg:tree (peg-parse passwd "one entry")) @result{}
+(entry "one entry")
+@end lisp
+
+By default, the parse trees generated by PEGs are compressed as much as possible without losing information. It may not look like this is what you want at first, but uncompressed parse trees are an enormous headache (there's no easy way to predict how deep particular lists will nest, there are empty lists littered everywhere, etc. etc.). One side-effect of this, however, is that sometimes the compressor is too aggressive. No information is discarded when @code{((entry "one entry"))} is compressed to @code{(entry "one entry")}, but in this particular case it probably isn't what we want. @*
+
+There are two functions for easily dealing with this: @code{keyword-flatten} and @code{context-flatten}. The @code{keyword-flatten} function takes a list of keywords and a list to flatten, then tries to coerce the list such that the first element of all sublists is one of the keywords. The @code{context-flatten} function is similar, but instead of a list of keywords it takes a predicate that should indicate whether a given sublist is good enough (refer to the API reference for more details). @*
+
+What we want here is @code{keyword-flatten}.
+@lisp
+(keyword-flatten '(entry) (peg:tree (peg-parse passwd *etc-passwd*))) @result{}
+((entry "root:x:0:0:root:/root:/bin/bash")
+ (entry "daemon:x:1:1:daemon:/usr/sbin:/bin/sh")
+ (entry "bin:x:2:2:bin:/bin:/bin/sh")
+ (entry "sys:x:3:3:sys:/dev:/bin/sh")
+ (entry "nobody:x:65534:65534:nobody:/nonexistent:/bin/sh")
+ (entry "messagebus:x:103:107::/var/run/dbus:/bin/false"))
+(keyword-flatten '(entry) (peg:tree (peg-parse passwd "one entry"))) @result{}
+((entry "one entry"))
+@end lisp
+
+Of course, this is a somewhat contrived example. In practice we would probably just tag the @code{passwd} nonterminal to remove the ambiguity (using either the @code{all} keyword for S-expressions or the @code{<--} symbol for strings)..
+
+@lisp
+(define-nonterm tag-passwd all (peg "entry* !."))
+(peg:tree (peg-parse tag-passwd *etc-passwd*)) @result{}
+(tag-passwd
+ (entry "root:x:0:0:root:/root:/bin/bash")
+ (entry "daemon:x:1:1:daemon:/usr/sbin:/bin/sh")
+ (entry "bin:x:2:2:bin:/bin:/bin/sh")
+ (entry "sys:x:3:3:sys:/dev:/bin/sh")
+ (entry "nobody:x:65534:65534:nobody:/nonexistent:/bin/sh")
+ (entry "messagebus:x:103:107::/var/run/dbus:/bin/false"))
+(peg:tree (peg-parse tag-passwd "one entry"))
+(tag-passwd
+ (entry "one entry"))
+@end lisp
+
+If you're ever uncertain about the potential results of parsing something, remember the two absolute rules: @*
+1. No parsing information will ever be discarded. @*
+2. There will never be any lists with fewer than 2 elements. @*
+
+For the purposes of (1), "parsing information" means things tagged with the @code{any} keyword or the @code{<--} symbol. Plain strings will be concatenated. @*
+
+Let's extend this example a bit more and actually pull some useful information out of the passwd file:
+@lisp
+(define-grammar
+ "passwd <-- entry* !.
+entry <-- login C pass C uid C gid C nameORcomment C homedir C shell NL*
+login <-- text
+pass <-- text
+uid <-- [0-9]*
+gid <-- [0-9]*
+nameORcomment <-- text
+homedir <-- path
+shell <-- path
+path <-- (SLASH pathELEMENT)*
+pathELEMENT <-- (!NL !C !'/' .)*
+text <- (!NL !C .)*
+C < ':'
+NL < '\n'
+SLASH < '/'")
+@end lisp
+
+This produces rather pretty parse trees:
+@lisp
+(passwd
+ (entry (login "root")
+ (pass "x")
+ (uid "0")
+ (gid "0")
+ (nameORcomment "root")
+ (homedir (path (pathELEMENT "root")))
+ (shell (path (pathELEMENT "bin") (pathELEMENT "bash"))))
+ (entry (login "daemon")
+ (pass "x")
+ (uid "1")
+ (gid "1")
+ (nameORcomment "daemon")
+ (homedir
+ (path (pathELEMENT "usr") (pathELEMENT "sbin")))
+ (shell (path (pathELEMENT "bin") (pathELEMENT "sh"))))
+ (entry (login "bin")
+ (pass "x")
+ (uid "2")
+ (gid "2")
+ (nameORcomment "bin")
+ (homedir (path (pathELEMENT "bin")))
+ (shell (path (pathELEMENT "bin") (pathELEMENT "sh"))))
+ (entry (login "sys")
+ (pass "x")
+ (uid "3")
+ (gid "3")
+ (nameORcomment "sys")
+ (homedir (path (pathELEMENT "dev")))
+ (shell (path (pathELEMENT "bin") (pathELEMENT "sh"))))
+ (entry (login "nobody")
+ (pass "x")
+ (uid "65534")
+ (gid "65534")
+ (nameORcomment "nobody")
+ (homedir (path (pathELEMENT "nonexistent")))
+ (shell (path (pathELEMENT "bin") (pathELEMENT "sh"))))
+ (entry (login "messagebus")
+ (pass "x")
+ (uid "103")
+ (gid "107")
+ nameORcomment
+ (homedir
+ (path (pathELEMENT "var")
+ (pathELEMENT "run")
+ (pathELEMENT "dbus")))
+ (shell (path (pathELEMENT "bin") (pathELEMENT "false")))))
+@end lisp
+
+Notice that when there's no entry in a field (e.g. @code{nameORcomment} for messagebus) the symbol is inserted. This is the ``don't throw away any information'' rule---we succesfully matched a @code{nameORcomment} of 0 characters (since we used @code{*} when defining it). This is usually what you want, because it allows you to e.g. use @code{list-ref} to pull out elements (since they all have known offsets). @*
+
+If you'd prefer not to have symbols for empty matches, you can replace the @code{*} with a @code{+} and add a @code{?} after the @code{nameORcomment} in @code{entry}. Then it will try to parse 1 or more characters, fail (inserting nothing into the parse tree), but continue because it didn't have to match the nameORcomment to continue.
+
+
+@subsubheading Embedding Arithmetic Expressions
+
+We can parse simple mathematical expressions with the following PEG:
+
+@lisp
+(define-grammar
+ "expr <- sum
+sum <-- (product ('+' / '-') sum) / product
+product <-- (value ('*' / '/') product) / value
+value <-- number / '(' expr ')'
+number <-- [0-9]+")
+@end lisp
+
+Then:
+@lisp
+(peg:tree (peg-parse expr "1+1/2*3+(1+1)/2")) @result{}
+(sum (product (value (number "1")))
+ "+"
+ (sum (product
+ (value (number "1"))
+ "/"
+ (product
+ (value (number "2"))
+ "*"
+ (product (value (number "3")))))
+ "+"
+ (sum (product
+ (value "("
+ (sum (product (value (number "1")))
+ "+"
+ (sum (product (value (number "1")))))
+ ")")
+ "/"
+ (product (value (number "2")))))))
+@end lisp
+
+There is very little wasted effort in this PEG. The @code{number} nonterminal has to be tagged because otherwise the numbers might run together with the arithmetic expressions during the string concatenation stage of parse-tree compression (the parser will see ``1'' followed by ``/'' and decide to call it ``1/''). When in doubt, tag.
+
+It is very easy to turn these parse trees into lisp expressions:
+@lisp
+(define (parse-sum sum left . rest)
+ (if (null? rest)
+ (apply parse-product left)
+ (list (string->symbol (car rest))
+ (apply parse-product left)
+ (apply parse-sum (cadr rest)))))
+
+(define (parse-product product left . rest)
+ (if (null? rest)
+ (apply parse-value left)
+ (list (string->symbol (car rest))
+ (apply parse-value left)
+ (apply parse-product (cadr rest)))))
+
+(define (parse-value value first . rest)
+ (if (null? rest)
+ (string->number (cadr first))
+ (apply parse-sum (car rest))))
+
+(define parse-expr parse-sum)
+@end lisp
+(Notice all these functions look very similar; for a more complicated PEG, it would be worth abstracting.)
+
+Then:
+@lisp
+(apply parse-expr (peg:tree (peg-parse expr "1+1/2*3+(1+1)/2"))) @result{}
+(+ 1 (+ (/ 1 (* 2 3)) (/ (+ 1 1) 2)))
+@end lisp
+
+But wait! The associativity is wrong! Where it says @code{(/ 1 (* 2 3))}, it should say @code{(* (/ 1 2) 3)}.
+
+It's tempting to try replacing e.g. @code{"sum <-- (product ('+' / '-') sum) / product"} with @code{"sum <-- (sum ('+' / '-') product) / product"}, but this is a Bad Idea. PEGs don't support left recursion. To see why, imagine what the parser will do here. When it tries to parse @code{sum}, it first has to try and parse @code{sum}. But to do that, it first has to try and parse @code{sum}. This will continue until the stack gets blown off.
+
+So how does one parse left-associative binary operators with PEGs? Honestly, this is one of their major shortcomings. There's no general-purpose way of doing this, but here the repetition operators are a good choice:
+
+@lisp
+(use-modules (srfi srfi-1))
+
+(define-grammar
+ "expr <- sum
+sum <-- (product ('+' / '-'))* product
+product <-- (value ('*' / '/'))* value
+value <-- number / '(' expr ')'
+number <-- [0-9]+")
+
+;; take a deep breath...
+(define (make-left-parser next-func)
+ (lambda (sum first . rest) ;; general form, comments below assume
+ ;; that we're dealing with a sum expression
+ (if (null? rest) ;; form (sum (product ...))
+ (apply next-func first)
+ (if (string? (cadr first));; form (sum ((product ...) "+") (product ...))
+ (list (string->symbol (cadr first))
+ (apply next-func (car first))
+ (apply next-func (car rest)))
+ ;; form (sum (((product ...) "+") ((product ...) "+")) (product ...))
+ (car
+ (reduce ;; walk through the list and build a left-associative tree
+ (lambda (l r)
+ (list (list (cadr r) (car r) (apply next-func (car l)))
+ (string->symbol (cadr l))))
+ 'ignore
+ (append ;; make a list of all the products
+ ;; the first one should be pre-parsed
+ (list (list (apply next-func (caar first))
+ (string->symbol (cadar first))))
+ (cdr first)
+ ;; the last one has to be added in
+ (list (append rest '("done"))))))))))
+
+(define (parse-value value first . rest)
+ (if (null? rest)
+ (string->number (cadr first))
+ (apply parse-sum (car rest))))
+(define parse-product (make-left-parser parse-value))
+(define parse-sum (make-left-parser parse-product))
+(define parse-expr parse-sum)
+@end lisp
+
+Then:
+@lisp
+(apply parse-expr (peg:tree (peg-parse expr "1+1/2*3+(1+1)/2"))) @result{}
+(+ (+ 1 (* (/ 1 2) 3)) (/ (+ 1 1) 2))
+@end lisp
+
+As you can see, this is much uglier (it could be made prettier by using @code{context-flatten}, but the way it's written above makes it clear how we deal with the three ways the zero-or-more @code{*} expression can parse). Fortunately, most of the time we can get away with only using right-associativity.
+
+@subsubheading Simplified Functions
+
+For a more tantalizing example, consider the following grammar that parses (highly) simplified C functions:
+@lisp
+(define-grammar
+ "cfunc <-- cSP ctype cSP cname cSP cargs cLB cSP cbody cRB
+ctype <-- cidentifier
+cname <-- cidentifier
+cargs <-- cLP (! (cSP cRP) carg cSP (cCOMMA / cRP) cSP)* cSP
+carg <-- cSP ctype cSP cname
+cbody <-- cstatement *
+cidentifier <- [a-zA-z][a-zA-Z0-9_]*
+cstatement <-- (!';'.)*cSC cSP
+cSC < ';'
+cCOMMA < ','
+cLP < '('
+cRP < ')'
+cLB < '@{'
+cRB < '@}'
+cSP < [ \t\n]*")
+@end lisp
+
+Then:
+@lisp
+(peg-parse cfunc "int square(int a) @{ return a*a;@}") @result{}
+(32
+ (cfunc (ctype "int")
+ (cname "square")
+ (cargs (carg (ctype "int") (cname "a")))
+ (cbody (cstatement "return a*a"))))
+@end lisp
+
+And:
+@lisp
+(peg-parse cfunc "int mod(int a, int b) @{ int c = a/b;return a-b*c; @}") @result{}
+(52
+ (cfunc (ctype "int")
+ (cname "mod")
+ (cargs (carg (ctype "int") (cname "a"))
+ (carg (ctype "int") (cname "b")))
+ (cbody (cstatement "int c = a/b")
+ (cstatement "return a- b*c"))))
+@end lisp
+
+By wrapping all the @code{carg} nonterminals in a @code{cargs} nonterminal, we were able to remove any ambiguity in the parsing structure and avoid having to call @code{context-flatten} on the output of @code{peg-parse}. We used the same trick with the @code{cstatement} nonterminals, wrapping them in a @code{cbody} nonterminal.
+
+The whitespace nonterminal @code{cSP} used here is a (very) useful instantiation of a common pattern for matching syntactically irrelevant information. Since it's tagged with @code{<} and ends with @code{*} it won't clutter up the parse trees (all the empty lists will be discarded during the compression step) and it will never cause parsing to fail.
+
* Input and Output:: Ports, reading and writing.
* Regular Expressions:: Pattern matching and substitution.
* LALR(1) Parsing:: Generating LALR(1) parsers.
+* PEG Parsing:: Parsing Expression Grammars.
* Read/Load/Eval/Compile:: Reading and evaluating Scheme code.
* Memory Management:: Memory management and garbage collection.
* Modules:: Designing reusable code libraries.
@include api-io.texi
@include api-regex.texi
@include api-lalr.texi
+@include api-peg.texi
@include api-evaluation.texi
@include api-memory.texi
@include api-modules.texi
ice-9/null.scm \
ice-9/occam-channel.scm \
ice-9/optargs.scm \
+ ice-9/peg.scm \
ice-9/poe.scm \
ice-9/poll.scm \
ice-9/posix.scm \
--- /dev/null
+(define-module (ice-9 peg)
+ :export (peg-sexp-compile peg-string-compile context-flatten peg-parse define-nonterm define-nonterm-f peg-match get-code define-grammar define-grammar-f peg:start peg:end peg:string peg:tree peg:substring peg-record? keyword-flatten)
+ :autoload (ice-9 pretty-print) (peg-sexp-compile peg-string-compile context-flatten peg-parse define-nonterm define-nonterm-f peg-match get-code define-grammar define-grammar-f keyword-flatten)
+ :use-module (ice-9 pretty-print))
+
+(use-modules (ice-9 pretty-print))
+
+(eval-when (compile load eval)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; CONVENIENCE MACROS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (eeval exp)
+ (eval exp (interaction-environment)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; MACRO BUILDERS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Safe-bind helps to bind macros safely.
+;; e.g.:
+;; (safe-bind
+;; (a b)
+;; `(,a ,b))
+;; gives:
+;; (#<uninterned-symbol a cc608d0> #<uninterned-symbol b cc608a0>)
+(define-syntax safe-bind
+ (lambda (x)
+ (syntax-case x ()
+ ((_ vals . actions)
+ (datum->syntax x (apply safe-bind-f
+ (cons
+ (syntax->datum #'vals)
+ (syntax->datum #'actions))))))))
+;; (define-macro (safe-bind vals . actions)
+;; (apply safe-bind-f (cons vals actions)))
+(define (safe-bind-f vals . actions)
+ `(let ,(map (lambda (val) `(,val (make-symbol ,(symbol->string val)))) vals)
+ ,@actions))
+
+;; Unsafe-bind is like safe-bind but uses symbols that are easier to read while
+;; debugging rather than safe ones. Currently unused.
+;; (define-macro (unsafe-bind vals . actions)
+;; (apply unsafe-bind-f (cons vals actions)))
+;; (define (unsafe-bind-f vals . actions)
+;; `(let ,(map (lambda (val) `(,val ',val)) vals)
+;; ,@actions))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; LOOPING CONSTRUCTS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Perform ACTION. If it succeeded, return its return value. If it failed, run
+;; IF_FAILS and try again
+(define-syntax until-works
+ (lambda (x)
+ (syntax-case x ()
+ ((_ action if-fails)
+ #'(let ((retval action))
+ (while (not retval)
+ if-fails
+ (set! retval action))
+ retval)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; GENERIC LIST-PROCESSING MACROS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Return #t if the list has only one element (calling length all the time on
+;; potentially long lists was really slow).
+(define-syntax single?
+ (lambda (x)
+ (syntax-case x ()
+ ((_ lst)
+ #'(and (list? lst) (not (null? lst)) (null? (cdr lst)))))))
+
+;; Push an object onto a list.
+(define-syntax push!
+ (lambda (x)
+ (syntax-case x ()
+ ((_ lst obj)
+ #'(set! lst (cons obj lst))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; CODE GENERATORS
+;; These functions generate scheme code for parsing PEGs.
+;; Conventions:
+;; accum: (all name body none)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Code we generate will be defined in a function, and always has to test
+;; whether it's beyond the bounds of the string before it executes.
+(define (cg-generic-lambda str strlen at code)
+ `(lambda (,str ,strlen ,at)
+ (if (>= ,at ,strlen)
+ #f
+ ,code)))
+;; The short name makes the formatting below much easier to read.
+(define cggl cg-generic-lambda)
+
+;; Optimizations for CG-GENERIC-RET below...
+(define *op-known-single-body* '(cg-string cg-peg-any cg-range))
+;; ...done with optimizations (could use more of these).
+
+;; Code we generate will have a certain return structure depending on how we're
+;; accumulating (the ACCUM variable).
+(define (cg-generic-ret accum name body-uneval at)
+ (safe-bind
+ (body)
+ `(let ((,body ,body-uneval))
+ ,(cond
+ ((and (eq? accum 'all) name body)
+ `(list ,at
+ (cond
+ ((not (list? ,body)) (list ',name ,body))
+ ((null? ,body) ',name)
+ ((symbol? (car ,body)) (list ',name ,body))
+ (#t (cons ',name ,body)))))
+ ((and (eq? accum 'name) name)
+ `(list ,at ',name))
+ ((and (eq? accum 'body) body)
+ (cond
+ ((member name *op-known-single-body*)
+ `(list ,at ,body))
+ (#t `(list ,at
+ (cond
+ (((@@ (ice-9 peg) single?) ,body) (car ,body))
+ (#t ,body))))))
+ ((eq? accum 'none)
+ `(list ,at '()))
+ (#t
+ (begin
+ (pretty-print `(cg-generic-ret-error ,accum ,name ,body-uneval ,at))
+ (pretty-print "Defaulting to accum of none.\n")
+ `(list ,at '())))))))
+;; The short name makes the formatting below much easier to read.
+(define cggr cg-generic-ret)
+
+;; Generates code that matches a particular string.
+;; E.g.: (cg-string "abc" 'body)
+(define (cg-string match accum)
+ (safe-bind
+ (str strlen at)
+ (let ((len (string-length match)))
+ (cggl str strlen at
+ `(if (string=? (substring ,str ,at (min (+ ,at ,len) ,strlen))
+ ,match)
+ ,(cggr accum 'cg-string match `(+ ,at ,len))
+ #f)))))
+
+;; Generates code for matching any character.
+;; E.g.: (cg-peg-any 'body)
+(define (cg-peg-any accum)
+ (safe-bind
+ (str strlen at)
+ (cggl str strlen at
+ (cggr accum 'cg-peg-any `(substring ,str ,at (+ ,at 1)) `(+ ,at 1)))))
+
+;; Generates code for matching a range of characters between start and end.
+;; E.g.: (cg-range #\a #\z 'body)
+(define (cg-range start end accum)
+ (safe-bind
+ (str strlen at c)
+ (cggl str strlen at
+ `(let ((,c (string-ref ,str ,at)))
+ (if (and
+ (char>=? ,c ,start)
+ (char<=? ,c ,end))
+ ,(cggr accum 'cg-range `(string ,c) `(+ ,at 1))
+ #f)))))
+
+;; Filters the accum argument to peg-sexp-compile for buildings like string
+;; literals (since we don't want to tag them with their name if we're doing an
+;; "all" accum).
+(define (builtin-accum-filter accum)
+ (cond
+ ((eq? accum 'all) 'body)
+ ((eq? accum 'name) 'name)
+ ((eq? accum 'body) 'body)
+ ((eq? accum 'none) 'none)))
+(define baf builtin-accum-filter)
+
+;; Takes a value, prints some debug output, and returns it.
+(define (error-val val)
+ (begin
+ (pretty-print val)
+ (pretty-print "Inserting into code for debugging.\n")
+ val))
+
+;; Takes an arbitrary expressions and accumulation variable, then parses it.
+;; E.g.: (peg-sexp-compile '(and "abc" (or "-" (range #\a #\z))) 'all)
+(define (peg-sexp-compile match accum)
+ (cond
+ ((string? match) (cg-string match (baf accum)))
+ ((symbol? match) ;; either peg-any or a nonterminal
+ (cond
+ ((eq? match 'peg-any) (cg-peg-any (baf accum)))
+ ;; if match is any other symbol it's a nonterminal, so just return it
+ (#t match)))
+ ((or (not (list? match)) (null? match))
+ ;; anything besides a string, symbol, or list is an error
+ (error-val `(peg-sexp-compile-error-1 ,match ,accum)))
+
+ ((eq? (car match) 'range) ;; range of characters (e.g. [a-z])
+ (cg-range (cadr match) (caddr match) (baf accum)))
+ ((eq? (car match) 'ignore) ;; match but don't parse
+ (peg-sexp-compile (cadr match) 'none))
+ ((eq? (car match) 'capture) ;; parse
+ (peg-sexp-compile (cadr match) 'body))
+ ((eq? (car match) 'peg) ;; embedded PEG string
+ (peg-string-compile (cadr match) (baf accum)))
+ ((eq? (car match) 'and) (cg-and (cdr match) (baf accum)))
+ ((eq? (car match) 'or) (cg-or (cdr match) (baf accum)))
+ ((eq? (car match) 'body)
+ (if (not (= (length match) 4))
+ (error-val `(peg-sexp-compile-error-2 ,match ,accum))
+ (apply cg-body (cons (baf accum) (cdr match)))))
+ (#t (error-val `(peg-sexp-compile-error-3 ,match ,accum)))))
+
+;;;;; Convenience macros for making sure things come out in a readable form.
+;; If SYM is a list of one element, return (car SYM), else return SYM.
+(define-syntax single-filter
+ (lambda (x)
+ (syntax-case x ()
+ ((_ sym)
+ #'(if (single? sym) (car sym) sym)))))
+;; If OBJ is non-null, push it onto LST, otherwise do nothing.
+(define-syntax push-not-null!
+ (lambda (x)
+ (syntax-case x ()
+ ((_ lst obj)
+ #'(if (not (null? obj)) (push! lst obj))))))
+
+;; Top-level function builder for AND. Reduces to a call to CG-AND-INT.
+(define (cg-and arglst accum)
+ (safe-bind
+ (str strlen at body)
+ `(lambda (,str ,strlen ,at)
+ (let ((,body '()))
+ ,(cg-and-int arglst accum str strlen at body)))))
+
+;; Internal function builder for AND (calls itself).
+(define (cg-and-int arglst accum str strlen at body)
+ (safe-bind
+ (res newat newbody)
+ (if (null? arglst)
+ (cggr accum 'cg-and `(reverse ,body) at) ;; base case
+ (let ((mf (peg-sexp-compile (car arglst) accum))) ;; match function
+ `(let ((,res (,mf ,str ,strlen ,at)))
+ (if (not ,res)
+ #f ;; if the match failed, the and failed
+ ;; otherwise update AT and BODY then recurse
+ (let ((,newat (car ,res))
+ (,newbody (cadr ,res)))
+ (set! ,at ,newat)
+ ((@@ (ice-9 peg) push-not-null!) ,body ((@@ (ice-9 peg) single-filter) ,newbody))
+ ,(cg-and-int (cdr arglst) accum str strlen at body))))))))
+
+;; Top-level function builder for OR. Reduces to a call to CG-OR-INT.
+(define (cg-or arglst accum)
+ (safe-bind
+ (str strlen at body)
+ `(lambda (,str ,strlen ,at)
+ ,(cg-or-int arglst accum str strlen at body))))
+
+;; Internal function builder for OR (calls itself).
+(define (cg-or-int arglst accum str strlen at body)
+ (safe-bind
+ (res)
+ (if (null? arglst)
+ #f ;; base case
+ (let ((mf (peg-sexp-compile (car arglst) accum)))
+ `(let ((,res (,mf ,str ,strlen ,at)))
+ (if ,res ;; if the match succeeds, we're done
+ ,(cggr accum 'cg-or `(cadr ,res) `(car ,res))
+ ,(cg-or-int (cdr arglst) accum str strlen at body)))))))
+
+;; Returns a block of code that tries to match MATCH, and on success updates AT
+;; and BODY, return #f on failure and #t on success.
+(define (cg-body-test match accum str strlen at body)
+ (safe-bind
+ (at2-body2 at2 body2)
+ (let ((mf (peg-sexp-compile match accum)))
+ `(let ((,at2-body2 (,mf ,str ,strlen ,at)))
+ (if (or (not ,at2-body2) (= ,at (car ,at2-body2)))
+ #f
+ (let ((,at2 (car ,at2-body2))
+ (,body2 (cadr ,at2-body2)))
+ (set! ,at ,at2)
+ ((@@ (ice-9 peg) push-not-null!)
+ ,body
+ ((@@ (ice-9 peg) single-filter) ,body2))
+ #t))))))
+
+;; Returns a block of code that sees whether NUM wants us to try and match more
+;; given that we've already matched COUNT.
+(define (cg-body-more num count)
+ (cond ((number? num) `(< ,count ,num))
+ ((eq? num '+) #t)
+ ((eq? num '*) #t)
+ ((eq? num '?) `(< ,count 1))
+ (#t (error-val `(cg-body-more-error ,num ,count)))))
+
+;; Returns a function that takes a paramter indicating whether or not the match
+;; was succesful and returns what the body expression should return.
+(define (cg-body-ret accum type name body at at2)
+ (safe-bind
+ (success)
+ `(lambda (,success)
+ ,(cond ((eq? type '!) `(if ,success #f ,(cggr accum name ''() at)))
+ ((eq? type '&) `(if ,success ,(cggr accum name ''() at) #f))
+ ((eq? type 'lit)
+ `(if ,success ,(cggr accum name `(reverse ,body) at2) #f))
+ (#t (error-val
+ `(cg-body-ret-error ,type ,accum ,name ,body ,at ,at2)))))))
+
+;; Returns a block of code that sees whether COUNT satisfies the constraints of
+;; NUM.
+(define (cg-body-success num count)
+ (cond ((number? num) `(= ,count ,num))
+ ((eq? num '+) `(>= ,count 1))
+ ((eq? num '*) #t)
+ ((eq? num '?) `(<= ,count 1))
+ (#t `(cg-body-success-error ,num))))
+
+;; Returns a function that parses a BODY element.
+(define (cg-body accum type match num)
+ (safe-bind
+ (str strlen at at2 count body)
+ `(lambda (,str ,strlen ,at)
+ (let ((,at2 ,at) (,count 0) (,body '()))
+ (while (and ,(cg-body-test match accum str strlen at2 body)
+ (set! ,count (+ ,count 1))
+ ,(cg-body-more num count)))
+ (,(cg-body-ret accum type 'cg-body body at at2)
+ ,(cg-body-success num count))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; FOR DEFINING AND USING NONTERMINALS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; The results of parsing using a nonterminal are cached. Think of it like a
+;; hash with no conflict resolution. Process for deciding on the cache size
+;; wasn't very scientific; just ran the benchmarks and stopped a little after
+;; the point of diminishing returns on my box.
+(define *cache-size* 512)
+
+;; Defines a new nonterminal symbol accumulating with ACCUM.
+(define-syntax define-nonterm
+ (lambda (x)
+ (syntax-case x ()
+ ((_ sym accum match)
+ (let ((matchf (peg-sexp-compile (syntax->datum #'match)
+ (syntax->datum #'accum)))
+ (symsym (syntax->datum #'sym))
+ (accumsym (syntax->datum #'accum))
+ (c (datum->syntax x (gensym))));; the cache
+ ;; CODE is the code to parse the string if the result isn't cached.
+ (let ((code
+ (safe-bind
+ (str strlen at res body)
+ `(lambda (,str ,strlen ,at)
+ (let ((,res (,matchf ,str ,strlen ,at)))
+ ;; Try to match the nonterminal.
+ (if ,res
+ ;; If we matched, do some post-processing to figure out
+ ;; what data to propagate upward.
+ (let ((,at (car ,res))
+ (,body (cadr ,res)))
+ ,(cond
+ ((eq? accumsym 'name)
+ `(list ,at ',symsym))
+ ((eq? accumsym 'all)
+ `(list (car ,res)
+ (cond
+ ((not (list? ,body))
+ (list ',symsym ,body))
+ ((null? ,body) ',symsym)
+ ((symbol? (car ,body))
+ (list ',symsym ,body))
+ (#t (cons ',symsym ,body)))))
+ ((eq? accumsym 'none) `(list (car ,res) '()))
+ (#t (begin res))))
+ ;; If we didn't match, just return false.
+ #f))))))
+ #`(begin
+ (define #,c (make-vector *cache-size* #f));; the cache
+ (define (sym str strlen at)
+ (let* ((vref (vector-ref #,c (modulo at *cache-size*))))
+ ;; Check to see whether the value is cached.
+ (if (and vref (eq? (car vref) str) (= (cadr vref) at))
+ (caddr vref);; If it is return it.
+ (let ((fres ;; Else calculate it and cache it.
+ (#,(datum->syntax x code) str strlen at)))
+ (vector-set! #,c (modulo at *cache-size*)
+ (list str at fres))
+ fres))))
+
+ ;; Store the code in case people want to debug.
+ (set-symbol-property!
+ 'sym 'code #,(datum->syntax x (list 'quote code)))
+ sym)))))))
+
+;; Gets the code corresponding to NONTERM
+(define-syntax get-code
+ (lambda (x)
+ (syntax-case x ()
+ ((_ nonterm)
+ #`(pretty-print (symbol-property 'nonterm 'code))))))
+
+;; Parses STRING using NONTERM
+(define (peg-parse nonterm string)
+ ;; We copy the string before using it because it might have been modified
+ ;; in-place since the last time it was parsed, which would invalidate the
+ ;; cache. Guile uses copy-on-write for strings, so this is fast.
+ (let ((res (nonterm (string-copy string) (string-length string) 0)))
+ (if (not res)
+ #f
+ (make-prec 0 (car res) string (string-collapse (cadr res))))))
+
+;; Searches through STRING for something that parses to PEG-MATCHER. Think
+;; regexp search.
+(define-syntax peg-match
+ (lambda (x)
+ (syntax-case x ()
+ ((_ peg-matcher string-uncopied)
+ (let ((pmsym (syntax->datum #'peg-matcher)))
+ (let ((peg-sexp-compile
+ (if (string? pmsym)
+ (peg-string-compile pmsym 'body)
+ (peg-sexp-compile pmsym 'body))))
+ ;; We copy the string before using it because it might have been
+ ;; modified in-place since the last time it was parsed, which would
+ ;; invalidate the cache. Guile uses copy-on-write for strings, so
+ ;; this is fast.
+ #`(let ((string (string-copy string-uncopied))
+ (strlen (string-length string-uncopied))
+ (at 0))
+ (let ((ret ((@@ (ice-9 peg) until-works)
+ (or (>= at strlen)
+ (#,(datum->syntax x peg-sexp-compile)
+ string strlen at))
+ (set! at (+ at 1)))))
+ (if (eq? ret #t) ;; (>= at strlen) succeeded
+ #f
+ (let ((end (car ret))
+ (match (cadr ret)))
+ (make-prec
+ at end string
+ (string-collapse match))))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; POST-PROCESSING FUNCTIONS (TO CANONICALIZE MATCH TREES)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Is everything in LST true?
+(define (andlst lst)
+ (or (null? lst)
+ (and (car lst) (andlst (cdr lst)))))
+
+;; Is LST a list of strings?
+(define (string-list? lst)
+ (and (list? lst) (not (null? lst))
+ (andlst (map string? lst))))
+
+;; Groups all strings that are next to each other in LST. Used in
+;; STRING-COLLAPSE.
+(define (string-group lst)
+ (if (not (list? lst))
+ lst
+ (if (null? lst)
+ '()
+ (let ((next (string-group (cdr lst))))
+ (if (not (string? (car lst)))
+ (cons (car lst) next)
+ (if (and (not (null? next))
+ (list? (car next))
+ (string? (caar next)))
+ (cons (cons (car lst) (car next)) (cdr next))
+ (cons (list (car lst)) next)))))))
+
+
+;; Collapses all the string in LST.
+;; ("a" "b" (c d) "e" "f") -> ("ab" (c d) "ef")
+(define (string-collapse lst)
+ (if (list? lst)
+ (let ((res (map (lambda (x) (if (string-list? x)
+ (apply string-append x)
+ x))
+ (string-group (map string-collapse lst)))))
+ (if (single? res) (car res) res))
+ lst))
+
+;; If LST is an atom, return (list LST), else return LST.
+(define (mklst lst)
+ (if (not (list? lst)) (list lst) lst))
+
+;; Takes a list and "flattens" it, using the predicate TST to know when to stop
+;; instead of terminating on atoms (see tutorial).
+(define (context-flatten tst lst)
+ (if (or (not (list? lst)) (null? lst))
+ lst
+ (if (tst lst)
+ (list lst)
+ (apply append
+ (map (lambda (x) (mklst (context-flatten tst x)))
+ lst)))))
+
+;; Takes a list and "flattens" it, using the list of keywords KEYWORD-LST to
+;; know when to stop at (see tutorial).
+(define (keyword-flatten keyword-lst lst)
+ (context-flatten
+ (lambda (x)
+ (if (or (not (list? x)) (null? x))
+ #t
+ (member (car x) keyword-lst)))
+ lst))
+
+;; Gets the left-hand depth of a list.
+(define (depth lst)
+ (if (or (not (list? lst)) (null? lst))
+ 0
+ (+ 1 (depth (car lst)))))
+
+;; Trims characters off the front and end of STR.
+;; (trim-1chars "'ab'") -> "ab"
+(define (trim-1chars str) (substring str 1 (- (string-length str) 1)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; Parse string PEGs using sexp PEGs.
+;; See the variable PEG-AS-PEG for an easier-to-read syntax.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Grammar for PEGs in PEG grammar.
+(define peg-as-peg
+"grammar <-- (nonterminal ('<--' / '<-' / '<') sp pattern)+
+pattern <-- alternative (SLASH sp alternative)*
+alternative <-- ([!&]? sp suffix)+
+suffix <-- primary ([*+?] sp)*
+primary <-- '(' sp pattern ')' sp / '.' sp / literal / charclass / nonterminal !'<'
+literal <-- ['] (!['] .)* ['] sp
+charclass <-- LB (!']' (CCrange / CCsingle))* RB sp
+CCrange <-- . '-' .
+CCsingle <-- .
+nonterminal <-- [a-zA-Z0-9-]+ sp
+sp < [ \t\n]*
+SLASH < '/'
+LB < '['
+RB < ']'
+")
+
+(define-nonterm peg-grammar all
+ (body lit (and peg-nonterminal (or "<--" "<-" "<") peg-sp peg-pattern) +))
+(define-nonterm peg-pattern all
+ (and peg-alternative
+ (body lit (and (ignore "/") peg-sp peg-alternative) *)))
+(define-nonterm peg-alternative all
+ (body lit (and (body lit (or "!" "&") ?) peg-sp peg-suffix) +))
+(define-nonterm peg-suffix all
+ (and peg-primary (body lit (and (or "*" "+" "?") peg-sp) *)))
+(define-nonterm peg-primary all
+ (or (and "(" peg-sp peg-pattern ")" peg-sp)
+ (and "." peg-sp)
+ peg-literal
+ peg-charclass
+ (and peg-nonterminal (body ! "<" 1))))
+(define-nonterm peg-literal all
+ (and "'" (body lit (and (body ! "'" 1) peg-any) *) "'" peg-sp))
+(define-nonterm peg-charclass all
+ (and (ignore "[")
+ (body lit (and (body ! "]" 1)
+ (or charclass-range charclass-single)) *)
+ (ignore "]")
+ peg-sp))
+(define-nonterm charclass-range all (and peg-any "-" peg-any))
+(define-nonterm charclass-single all peg-any)
+(define-nonterm peg-nonterminal all
+ (and (body lit (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) "-") +) peg-sp))
+(define-nonterm peg-sp none
+ (body lit (or " " "\t" "\n") *))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; PARSE STRING PEGS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Pakes a string representing a PEG grammar and defines all the nonterminals in
+;; it as the associated PEGs.
+(define (peg-parser str)
+ (let ((parsed (peg-parse peg-grammar str)))
+ (if (not parsed)
+ (begin
+ ;; (pretty-print "Invalid PEG grammar!\n")
+ #f)
+ (let ((lst (peg:tree parsed)))
+ (cond
+ ((or (not (list? lst)) (null? lst))
+ lst)
+ ((eq? (car lst) 'peg-grammar)
+ (cons 'begin (map (lambda (x) (peg-parse-nonterm x))
+ (context-flatten (lambda (lst) (<= (depth lst) 2))
+ (cdr lst))))))))))
+
+;; Macro wrapper for PEG-PARSER. Parses PEG grammars expressed as strings and
+;; defines all the appropriate nonterminals.
+(define-syntax define-grammar
+ (lambda (x)
+ (syntax-case x ()
+ ((_ str)
+ (datum->syntax x (peg-parser (syntax->datum #'str)))))))
+(define define-grammar-f peg-parser)
+
+;; Parse a nonterminal and pattern listed in LST.
+(define (peg-parse-nonterm lst)
+ (let ((nonterm (car lst))
+ (grabber (cadr lst))
+ (pattern (caddr lst)))
+ `(define-nonterm ,(string->symbol (cadr nonterm))
+ ,(cond
+ ((string=? grabber "<--") 'all)
+ ((string=? grabber "<-") 'body)
+ (#t 'none))
+ ,(compressor (peg-parse-pattern pattern)))))
+
+;; Parse a pattern.
+(define (peg-parse-pattern lst)
+ (cons 'or (map peg-parse-alternative
+ (context-flatten (lambda (x) (eq? (car x) 'peg-alternative))
+ (cdr lst)))))
+
+;; Parse an alternative.
+(define (peg-parse-alternative lst)
+ (cons 'and (map peg-parse-body
+ (context-flatten (lambda (x) (or (string? (car x))
+ (eq? (car x) 'peg-suffix)))
+ (cdr lst)))))
+
+;; Parse a body.
+(define (peg-parse-body lst)
+ (let ((suffix '())
+ (front 'lit))
+ (cond
+ ((eq? (car lst) 'peg-suffix)
+ (set! suffix lst))
+ ((string? (car lst))
+ (begin (set! front (string->symbol (car lst)))
+ (set! suffix (cadr lst))))
+ (#t `(peg-parse-body-fail ,lst)))
+ `(body ,front ,@(peg-parse-suffix suffix))))
+
+;; Parse a suffix.
+(define (peg-parse-suffix lst)
+ (list (peg-parse-primary (cadr lst))
+ (if (null? (cddr lst))
+ 1
+ (string->symbol (caddr lst)))))
+
+;; Parse a primary.
+(define (peg-parse-primary lst)
+ (let ((el (cadr lst)))
+ (cond
+ ((list? el)
+ (cond
+ ((eq? (car el) 'peg-literal)
+ (peg-parse-literal el))
+ ((eq? (car el) 'peg-charclass)
+ (peg-parse-charclass el))
+ ((eq? (car el) 'peg-nonterminal)
+ (string->symbol (cadr el)))))
+ ((string? el)
+ (cond
+ ((equal? el "(")
+ (peg-parse-pattern (caddr lst)))
+ ((equal? el ".")
+ 'peg-any)
+ (#t `(peg-parse-any unknown-string ,lst))))
+ (#t `(peg-parse-any unknown-el ,lst)))))
+
+;; Parses a literal.
+(define (peg-parse-literal lst) (trim-1chars (cadr lst)))
+
+;; Parses a charclass.
+(define (peg-parse-charclass lst)
+ (cons 'or
+ (map
+ (lambda (cc)
+ (cond
+ ((eq? (car cc) 'charclass-range)
+ `(range ,(string-ref (cadr cc) 0) ,(string-ref (cadr cc) 2)))
+ ((eq? (car cc) 'charclass-single)
+ (cadr cc))))
+ (context-flatten
+ (lambda (x) (or (eq? (car x) 'charclass-range)
+ (eq? (car x) 'charclass-single)))
+ (cdr lst)))))
+
+;; Compresses a list to save the optimizer work.
+;; e.g. (or (and a)) -> a
+(define (compressor lst)
+ (if (or (not (list? lst)) (null? lst))
+ lst
+ (cond
+ ((and (or (eq? (car lst) 'or) (eq? (car lst) 'and))
+ (null? (cddr lst)))
+ (compressor (cadr lst)))
+ ((and (eq? (car lst) 'body)
+ (eq? (cadr lst) 'lit)
+ (eq? (cadddr lst) 1))
+ (compressor (caddr lst)))
+ (#t (map compressor lst)))))
+
+;; Builds a lambda-expressions for the pattern STR using accum.
+(define (peg-string-compile str accum)
+ (peg-sexp-compile
+ (compressor (peg-parse-pattern (peg:tree (peg-parse peg-pattern str))))
+ accum))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; PMATCH STRUCTURE MUNGING
+;; Pretty self-explanatory.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define prec
+ (make-record-type "peg" '(start end string tree)))
+(define make-prec
+ (record-constructor prec '(start end string tree)))
+(define (peg:start pm)
+ (if pm ((record-accessor prec 'start) pm) #f))
+(define (peg:end pm)
+ (if pm ((record-accessor prec 'end) pm) #f))
+(define (peg:string pm)
+ (if pm ((record-accessor prec 'string) pm) #f))
+(define (peg:tree pm)
+ (if pm ((record-accessor prec 'tree) pm) #f))
+(define (peg:substring pm)
+ (if pm (substring (peg:string pm) (peg:start pm) (peg:end pm)) #f))
+(define peg-record? (record-predicate prec))
+
+)
+
tests/optargs.test \
tests/options.test \
tests/parameters.test \
+ tests/peg.test \
tests/peval.test \
tests/print.test \
tests/procprop.test \
--- /dev/null
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; PEG benchmark suite (minimal right now).
+;; Parses very long equations several times; outputs the average time
+;; it took and the standard deviation of times.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(use-modules (ice-9 pretty-print))
+(use-modules (srfi srfi-1))
+(use-modules (ice-9 peg))
+(use-modules (ice-9 popen))
+
+;; Generate random equations.
+(define (gen-rand-eq len)
+ (if (= len 0)
+ (random 1000)
+ (let ((len (if (even? len) (+ len 1) len)))
+ (map (lambda (x)
+ (if (odd? x)
+ (gen-rand len 'op)
+ (gen-rand len 'number)))
+ (iota len)))))
+(define (gen-rand len type)
+ (cond ((eq? type 'number)
+ (cond
+ ((= (random 5) 0) (gen-rand-eq (floor (/ len 5))))
+ (#t (random 1000))))
+ (#t (list-ref '(+ - * /) (random 4)))))
+
+;; Generates a random equation string (len is a rough indicator of the
+;; resulting length).
+(define (gen-str len)
+ (with-output-to-string (lambda () (write (gen-rand-eq len)))))
+
+;; Generates a left-associative parser (see tutorial).
+(define (make-left-parser next-func)
+ (lambda (sum first . rest)
+ (if (null? rest)
+ (apply next-func first)
+ (if (string? (cadr first))
+ (list (string->symbol (cadr first))
+ (apply next-func (car first))
+ (apply next-func (car rest)))
+ (car
+ (reduce
+ (lambda (l r)
+ (list (list (cadr r) (car r) (apply next-func (car l)))
+ (string->symbol (cadr l))))
+ 'ignore
+ (append
+ (list (list (apply next-func (caar first))
+ (string->symbol (cadar first))))
+ (cdr first)
+ (list (append rest '("done"))))))))))
+
+;; Functions for parsing equations (see tutorial).
+(define (parse-value value first . rest)
+ (if (null? rest)
+ (string->number (cadr first))
+ (apply parse-sum (car rest))))
+(define parse-product (make-left-parser parse-value))
+(define parse-sum (make-left-parser parse-product))
+(define parse-expr parse-sum)
+(define (eq-parse str) (apply parse-expr (peg:tree (peg-parse expr str))))
+
+;; PEG for parsing equations (see tutorial).
+(define-grammar
+ "expr <- sum
+sum <-- (product ('+' / '-'))* product
+product <-- (value ('*' / '/'))* value
+value <-- sp number sp / sp '(' expr ')' sp
+number <-- [0-9]+
+sp < [ \t\n]*")
+
+;; gets the time in seconds (with a fractional part)
+(define (canon-time)
+ (let ((pair (gettimeofday)))
+ (+ (+ (car pair) (* (cdr pair) (expt 10 -6))) 0.0)))
+
+;; Times how long it takes for FUNC to complete when called on ARGS.
+;; **SIDE EFFECT** Writes the time FUNC took to stdout.
+;; Returns the return value of FUNC.
+(define (time-func func . args)
+ (let ((start (canon-time)))
+ (let ((res (apply func args)))
+ (pretty-print `(took ,(- (canon-time) start) seconds))
+ res)))
+;; Times how long it takes for FUNC to complete when called on ARGS.
+;; Returns the time FUNC took to complete.
+(define (time-ret-func func . args)
+ (let ((start (canon-time)))
+ (let ((res (apply func args)))
+ (- (canon-time) start))))
+
+;; test string (randomly generated)
+(define tst1 "(621 - 746 * 945 - 194 * (204 * (965 - 738 + (846)) - 450 / (116 * 293 * 543) + 858 / 693 - (890 * (260) - 855) + 875 - 684 / (749 - (846) + 127) / 670) - 293 - 815 - 628 * 93 - 662 + 561 / 645 + 112 - 71 - (286 - ((324) / 424 + 956) / 190 + ((848) / 132 * 602) + 5 + 765 * 220 - ((801) / 191 - 299) * 708 + 151 * 682) + (943 + 847 - 145 - 816 / 550 - 217 / 9 / 969 * 524 * 447 / 323) * 991 - 283 * 915 / 733 / 478 / (680 + 343 * 186 / 341 * ((571) * 848 - 47) - (492 + 398 * (616)) + 270 - 539 * 34 / 47 / 458) * 417 / 406 / 354 * 678 + 524 + 40 / 282 - 792 * 570 - 305 * 14 + (248 - 678 * 8 - 53 - 215 / 677 - 665 / 216 - 275 - 462 / 502) - 24 - 780 + (967 / (636 / 400 * 823) + 933 - 361 - 620 - 255 / 372 + 394 * 869 / 839 * 727) + (436 + 993 - 668 + 772 - 33 + 64 - 252 * 957 * 320 + 540 / (23 * 74 / (422))) + (516 / (348 * 219 * 986) * 85 * 149 * 957 * 602 / 141 / 80 / 456 / 92 / (443 * 468 * 466)) * 568 / (271 - 42 + 271 + 592 + 71 * (766 + (11) * 946) / 728 / 137 / 111 + 557 / 962) * 179 - 936 / 821 * 101 - 206 / (267 - (11 / 906 * 290) / 722 / 98 - 987 / 989 - 470 * 833 - (720 / 34 - 280) + 638 / 940) - 889 * 84 * 630 + ((214 - 888 + (46)) / 540 + 941 * 724 / 759 * (679 / 527 - 764) * 413 + 831 / 559 - (308 / 796 / 737) / 20))")
+
+;; appends two equations (adds them together)
+(define (eq-append . eqs)
+ (if (null? eqs)
+ "0"
+ (if (null? (cdr eqs))
+ (car eqs)
+ (string-append
+ (car eqs)
+ " + "
+ (apply eq-append (cdr eqs))))))
+
+;; concatenates an equation onto itself n times using eq-append
+(define (string-n str n)
+ (if (<= n 0)
+ "0"
+ (if (= n 1)
+ str
+ (eq-append str (string-n str (- n 1))))))
+
+;; standard deviation (no bias-correction)
+;; (also called population standard deviation)
+(define (stddev . lst)
+ (let ((llen (length lst)))
+ (if (<= llen 0)
+ 0
+ (let* ((avg (/ (reduce + 0 lst) llen))
+ (mapfun (lambda (x) (real-part (expt (- x avg) 2)))))
+ (sqrt (/ (reduce + 0 (map mapfun lst)) llen))))))
+
+;; average
+(define (avg . lst)
+ (if (null? lst)
+ 0
+ (/ (reduce + 0 lst) (length lst))))
+
+(pretty-print "Parsing equations (see PEG in tutorial). Sample size of 10 for each test.")
+(pretty-print
+ (let ((lst
+ (map
+ (lambda (ignore)
+ (reduce-right
+ append
+ 0
+ (map
+ (lambda (x)
+ (let* ((mstr (string-n tst1 x))
+ (strlen (string-length mstr)))
+ (let ((func (lambda () (begin (peg-parse expr mstr)
+ 'done))))
+ `(((string of length ,strlen first pass)
+ ,(time-ret-func func))
+ ((string of length ,strlen second pass)
+ ,(time-ret-func func))))))
+ (filter (lambda (x) (= (modulo x 25) 0)) (iota 100)))))
+ (iota 10))))
+ (let ((compacted
+ (reduce-right
+ (lambda (accum conc)
+ (map (lambda (l r) (append l (cdr r))) accum conc))
+ 0
+ lst)))
+ (map
+ (lambda (els)
+ `(,(car els)
+ (average time in seconds ,(apply avg (cdr els)))
+ (standard deviation ,(apply stddev (cdr els)))))
+ compacted))))
+
+(define (sys-calc str)
+ (let* ((pipe (open-input-pipe (string-append "echo \"" str "\" | bc -l")))
+ (str (read pipe)))
+ (close-pipe pipe)
+ str))
+(define (lisp-calc str)
+ (+ (eval (eq-parse str) (interaction-environment)) 0.0))
+
+;; (pretty-print `(,(sys-calc tst1) ,(lisp-calc tst1)))
\ No newline at end of file
--- /dev/null
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; PEG test suite.
+;; Tests the parsing capabilities of (ice-9 peg). Could use more
+;; tests for edge cases.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-module (test-suite test-peg)
+ :use-module (test-suite lib)
+ :use-module (ice-9 peg)
+ :use-module (ice-9 pretty-print)
+ :use-module (srfi srfi-1))
+
+;; Doubled up for pasting into REPL.
+(use-modules (test-suite lib))
+(use-modules (ice-9 peg))
+(use-modules (ice-9 pretty-print))
+(use-modules (srfi srfi-1))
+
+;; Evaluates an expression at the toplevel. Not the prettiest
+;; solution to runtime issues ever, but m3h. Runs at toplevel so that
+;; symbols are bound globally instead of in the scope of the pass-if
+;; expression.
+(define (eeval exp)
+ (eval exp (interaction-environment)))
+(define make-prec (@@ (ice-9 peg) make-prec))
+
+;; Maps the nonterminals defined in the PEG parser written as a PEG to
+;; the nonterminals defined in the PEG parser written with
+;; S-expressions.
+(define grammar-mapping
+ '((grammar peg-grammar)
+ (pattern peg-pattern)
+ (alternative peg-alternative)
+ (suffix peg-suffix)
+ (primary peg-primary)
+ (literal peg-literal)
+ (charclass peg-charclass)
+ (CCrange charclass-range)
+ (CCsingle charclass-single)
+ (nonterminal peg-nonterminal)
+ (sp peg-sp)))
+
+;; Transforms the nonterminals defined in the PEG parser written as a PEG to the nonterminals defined in the PEG parser written with S-expressions.
+(define (grammar-transform x)
+ (let ((res (assoc x grammar-mapping)))
+ (if res (cadr res) x)))
+
+;; Maps a function onto a tree (recurses until it finds atoms, then calls the function on the atoms).
+(define (tree-map fn lst)
+ (if (list? lst)
+ (if (null? lst)
+ lst
+ (cons (tree-map fn (car lst))
+ (tree-map fn (cdr lst))))
+ (fn lst)))
+
+;; Tests to make sure that we can parse a PEG defining a grammar for
+;; PEGs, then uses that grammar to parse the same PEG again to make
+;; sure we get the same result (i.e. make sure our PEG grammar
+;; expressed as a PEG is equivalent to our PEG grammar expressed with
+;; S-expressions).
+(with-test-prefix "PEG Grammar"
+ (pass-if
+ "defining PEGs with PEG"
+ (and (eeval `(define-grammar ,(@@ (ice-9 peg) peg-as-peg))) #t))
+ (pass-if
+ "equivalence of definitions"
+ (equal?
+ (peg:tree (peg-parse (@@ (ice-9 peg) peg-grammar) (@@ (ice-9 peg) peg-as-peg)))
+ (tree-map
+ grammar-transform
+ (peg:tree (peg-parse grammar (@@ (ice-9 peg) peg-as-peg)))))))
+
+;; A grammar for pascal-style comments from Wikipedia.
+(define comment-grammar
+ "Begin <-- '(*'
+End <-- '*)'
+C <- Begin N* End
+N <- C / (!Begin !End Z)
+Z <- .")
+
+;; A short /etc/passwd file.
+(define *etc-passwd*
+ "root:x:0:0:root:/root:/bin/bash
+daemon:x:1:1:daemon:/usr/sbin:/bin/sh
+bin:x:2:2:bin:/bin:/bin/sh
+sys:x:3:3:sys:/dev:/bin/sh
+nobody:x:65534:65534:nobody:/nonexistent:/bin/sh
+messagebus:x:103:107::/var/run/dbus:/bin/false
+")
+
+;; A grammar for parsing /etc/passwd files.
+(define-grammar
+ "passwd <-- entry* !.
+entry <-- login CO pass CO uid CO gid CO nameORcomment CO homedir CO shell NL*
+login <-- text
+pass <-- text
+uid <-- [0-9]*
+gid <-- [0-9]*
+nameORcomment <-- text
+homedir <-- path
+shell <-- path
+path <-- (SLASH pathELEMENT)*
+pathELEMENT <-- (!NL !CO !'/' .)*
+text <- (!NL !CO .)*
+CO < ':'
+NL < '\n'
+SLASH < '/'")
+
+;; Tests some actual parsing using PEGs.
+(with-test-prefix "Parsing"
+ (eeval `(define-grammar ,comment-grammar))
+ (pass-if
+ ;; Pascal-style comment parsing
+ "simple comment"
+ (equal?
+ (peg-parse C "(*blah*)")
+ (make-prec 0 8 "(*blah*)"
+ '((Begin "(*") "blah" (End "*)")))))
+ (pass-if
+ "simple comment padded"
+ (equal?
+ (peg-parse C "(*blah*)abc")
+ (make-prec 0 8 "(*blah*)abc"
+ '((Begin "(*") "blah" (End "*)")))))
+ (pass-if
+ "nested comment"
+ (equal?
+ (peg-parse C "(*1(*2*)*)")
+ (make-prec 0 10 "(*1(*2*)*)"
+ '((Begin "(*") ("1" ((Begin "(*") "2" (End "*)"))) (End "*)")))))
+ (pass-if
+ "early termination"
+ (not (peg-parse C "(*blah")))
+ (pass-if
+ "never starts"
+ (not (peg-parse C "blah")))
+ ;; /etc/passwd parsing
+ (pass-if
+ "/etc/passwd"
+ (equal?
+ (peg-parse passwd *etc-passwd*)
+ (make-prec 0 220 *etc-passwd*
+ '(passwd (entry (login "root") (pass "x") (uid "0") (gid "0") (nameORcomment "root") (homedir (path (pathELEMENT "root"))) (shell (path (pathELEMENT "bin") (pathELEMENT "bash")))) (entry (login "daemon") (pass "x") (uid "1") (gid "1") (nameORcomment "daemon") (homedir (path (pathELEMENT "usr") (pathELEMENT "sbin"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "bin") (pass "x") (uid "2") (gid "2") (nameORcomment "bin") (homedir (path (pathELEMENT "bin"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "sys") (pass "x") (uid "3") (gid "3") (nameORcomment "sys") (homedir (path (pathELEMENT "dev"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "nobody") (pass "x") (uid "65534") (gid "65534") (nameORcomment "nobody") (homedir (path (pathELEMENT "nonexistent"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "messagebus") (pass "x") (uid "103") (gid "107") nameORcomment (homedir (path (pathELEMENT "var") (pathELEMENT "run") (pathELEMENT "dbus"))) (shell (path (pathELEMENT "bin") (pathELEMENT "false")))))))))
+
+;; Tests the functions for pulling data out of PEG Match Records.
+(with-test-prefix "PEG Match Records"
+ (define-nonterm bs all (peg "'b'+"))
+ (pass-if
+ "basic parameter extraction"
+ (equal?
+ (let ((pm (peg-match bs "aabbcc")))
+ `((string ,(peg:string pm))
+ (start ,(peg:start pm))
+ (end ,(peg:end pm))
+ (substring ,(peg:substring pm))
+ (tree ,(peg:tree pm))
+ (record? ,(peg-record? pm))))
+ '((string "aabbcc")
+ (start 2)
+ (end 4)
+ (substring "bb")
+ (tree (bs "bb"))
+ (record? #t)))))
+
+;; PEG for parsing right-associative equations.
+(define-grammar
+ "expr <- sum
+sum <-- (product ('+' / '-') sum) / product
+product <-- (value ('*' / '/') product) / value
+value <-- number / '(' expr ')'
+number <-- [0-9]+")
+
+;; Functions to actually evaluate the equations parsed with the PEG.
+(define (parse-sum sum left . rest)
+ (if (null? rest)
+ (apply parse-product left)
+ (list (string->symbol (car rest))
+ (apply parse-product left)
+ (apply parse-sum (cadr rest)))))
+
+(define (parse-product product left . rest)
+ (if (null? rest)
+ (apply parse-value left)
+ (list (string->symbol (car rest))
+ (apply parse-value left)
+ (apply parse-product (cadr rest)))))
+
+(define (parse-value value first . rest)
+ (if (null? rest)
+ (string->number (cadr first))
+ (apply parse-sum (car rest))))
+
+(define parse-expr parse-sum)
+(define (eq-parse str) (apply parse-expr (peg:tree (peg-parse expr str))))
+
+(with-test-prefix "Parsing right-associative equations"
+ (pass-if
+ "1"
+ (equal? (eq-parse "1") 1))
+ (pass-if
+ "1+2"
+ (equal? (eq-parse "1+2") '(+ 1 2)))
+ (pass-if
+ "1+2+3"
+ (equal? (eq-parse "1+2+3") '(+ 1 (+ 2 3))))
+ (pass-if
+ "1+2*3+4"
+ (equal? (eq-parse "1+2*3+4") '(+ 1 (+ (* 2 3) 4))))
+ (pass-if
+ "1+2/3*(4+5)/6-7-8"
+ (equal? (eq-parse "1+2/3*(4+5)/6-7-8")
+ '(+ 1 (- (/ 2 (* 3 (/ (+ 4 5) 6))) (- 7 8)))))
+ (pass-if
+ "1+1/2*3+(1+1)/2"
+ (equal? (eq-parse "1+1/2*3+(1+1)/2")
+ '(+ 1 (+ (/ 1 (* 2 3)) (/ (+ 1 1) 2))))))
+
+;; PEG for parsing left-associative equations (normal ones).
+(define-grammar
+ "expr <- sum
+sum <-- (product ('+' / '-'))* product
+product <-- (value ('*' / '/'))* value
+value <-- number / '(' expr ')'
+number <-- [0-9]+")
+
+;; Functions to actually evaluate the equations parsed with the PEG.
+(define (make-left-parser next-func)
+ (lambda (sum first . rest)
+ (if (null? rest)
+ (apply next-func first)
+ (if (string? (cadr first))
+ (list (string->symbol (cadr first))
+ (apply next-func (car first))
+ (apply next-func (car rest)))
+ (car
+ (reduce
+ (lambda (l r)
+ (list (list (cadr r) (car r) (apply next-func (car l)))
+ (string->symbol (cadr l))))
+ 'ignore
+ (append
+ (list (list (apply next-func (caar first))
+ (string->symbol (cadar first))))
+ (cdr first)
+ (list (append rest '("done"))))))))))
+
+(define (parse-value value first . rest)
+ (if (null? rest)
+ (string->number (cadr first))
+ (apply parse-sum (car rest))))
+(define parse-product (make-left-parser parse-value))
+(define parse-sum (make-left-parser parse-product))
+(define parse-expr parse-sum)
+(define (eq-parse str) (apply parse-expr (peg:tree (peg-parse expr str))))
+
+(with-test-prefix "Parsing left-associative equations"
+ (pass-if
+ "1"
+ (equal? (eq-parse "1") 1))
+ (pass-if
+ "1+2"
+ (equal? (eq-parse "1+2") '(+ 1 2)))
+ (pass-if
+ "1+2+3"
+ (equal? (eq-parse "1+2+3") '(+ (+ 1 2) 3)))
+ (pass-if
+ "1+2*3+4"
+ (equal? (eq-parse "1+2*3+4") '(+ (+ 1 (* 2 3)) 4)))
+ (pass-if
+ "1+2/3*(4+5)/6-7-8"
+ (equal? (eq-parse "1+2/3*(4+5)/6-7-8")
+ '(- (- (+ 1 (/ (* (/ 2 3) (+ 4 5)) 6)) 7) 8)))
+ (pass-if
+ "1+1/2*3+(1+1)/2"
+ (equal? (eq-parse "1+1/2*3+(1+1)/2")
+ '(+ (+ 1 (* (/ 1 2) 3)) (/ (+ 1 1) 2)))))
+
HCoop / bpt / guile.git / commitdiff