[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, mlucy, updated. release_1-9-11-163-gd0
|
From: |
Michael Lucy |
|
Subject: |
[Guile-commits] GNU Guile branch, mlucy, updated. release_1-9-11-163-gd0b4bf1 |
|
Date: |
Mon, 16 Aug 2010 05:06:51 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=d0b4bf1807fa9568b7291142fa56ded72f91abd5
The branch, mlucy has been updated
via d0b4bf1807fa9568b7291142fa56ded72f91abd5 (commit)
via 21347b8659f0c83c9db0758ef084ab669a2b8c6b (commit)
from 486e0b46f8b3b195c5c57daac024abdbb856ddeb (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit d0b4bf1807fa9568b7291142fa56ded72f91abd5
Author: Michael Lucy <address@hidden>
Date: Mon Aug 16 00:06:22 2010 -0500
Done.
commit 21347b8659f0c83c9db0758ef084ab669a2b8c6b
Author: Michael Lucy <address@hidden>
Date: Sun Aug 15 19:18:42 2010 -0500
Cleaned everything up.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-peg.texi | 2 +-
module/ice-9/peg.scm | 377 +++++++++++++++++--------------------------
test-suite/tests/peg.bench | 173 ++++++++++++++++++++
test-suite/tests/peg.test | 245 ++--------------------------
4 files changed, 341 insertions(+), 456 deletions(-)
create mode 100644 test-suite/tests/peg.bench
diff --git a/doc/ref/api-peg.texi b/doc/ref/api-peg.texi
index f2d7bdb..f9eb7ff 100644
--- a/doc/ref/api-peg.texi
+++ b/doc/ref/api-peg.texi
@@ -56,7 +56,7 @@ Parses @code{a} as many times in a row as it can, starting
each @code{a} at the
Optional @code{a}: @*
Tries to parse @code{a}. Succeeds if @code{a} succeeds. @*
address@hidden"e?"} @*
address@hidden"a?"} @*
@code{(body lit a ?)} @*
And predicate @code{a}: @*
diff --git a/module/ice-9/peg.scm b/module/ice-9/peg.scm
index 2765da8..b8613c0 100644
--- a/module/ice-9/peg.scm
+++ b/module/ice-9/peg.scm
@@ -43,26 +43,8 @@
;;;;; LOOPING CONSTRUCTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; If TST is true, evaluate BODY and try again.
-;; (turns out this is built-in, so I don't export it)
-;;;;;Old Def:
-;; (define-macro (while tst . body)
-;; `(do () ((not ,tst))
-;; ,@body))
-
-
-;; perform ACTION
-;; if it succeeded, return its return value
-;; if it failed, run IF_FAILS and try again
-;;;;;Old Def:
-;; (define-macro (until-works action if-fails)
-;; (safe-bind
-;; (retval)
-;; `(let ((,retval ,action))
-;; (while (not ,retval)
-;; ,if-fails
-;; (set! ,retval ,action))
-;; ,retval)))
+;; 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 ()
@@ -77,21 +59,15 @@
;;;;; 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)
-;;;;;Old Def:
-;; (define-macro (single? lst)
-;; `(and (list? ,lst) (not (null? ,lst)) (null? (cdr ,lst))))
+;; 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
-;;;;;Old Def:
-;; (define-macro (push! lst obj)
-;; `(set! ,lst (cons ,obj ,lst)))
+;; Push an object onto a list.
(define-syntax push!
(lambda (x)
(syntax-case x ()
@@ -112,11 +88,12 @@
(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.
+;; ...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).
@@ -149,6 +126,7 @@
(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.
@@ -184,7 +162,7 @@
,(cggr accum 'cg-range `(string ,c) `(+ ,at 1))
#f)))))
-;; Filters the accum argument to cg-match-func four buildings like string
+;; 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)
@@ -203,8 +181,8 @@
val))
;; Takes an arbitrary expressions and accumulation variable, then parses it.
-;; E.g.: (cg-match-func '(and "abc" (or "-" (range #\a #\z))) 'all)
-(define (cg-match-func match accum)
+;; 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
@@ -214,42 +192,39 @@
(#t match)))
((or (not (list? match)) (null? match))
;; anything besides a string, symbol, or list is an error
- (error-val `(cg-match-func-error-1 ,match ,accum)))
+ (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
- (cg-match-func (cadr match) 'none))
+ (peg-sexp-compile (cadr match) 'none))
((eq? (car match) 'capture) ;; parse
- (cg-match-func (cadr match) 'body))
- ((eq? (car match) 'peg)
- (pattern-builder (cadr match) (baf accum)))
+ (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 `(cg-match-func-error-2 ,match ,accum))
+ (error-val `(peg-sexp-compile-error-2 ,match ,accum))
(apply cg-body (cons (baf accum) (cdr match)))))
- (#t (error-val `(cg-match-func-error-3 ,match ,accum)))))
+ (#t (error-val `(peg-sexp-compile-error-3 ,match ,accum)))))
;;;;; Convenience macros for making sure things come out in a readable form.
-;;;;;Old Def:
-;; (define-macro (single-filter sym) `(if (single? ,sym) (car ,sym) ,sym))
+;; 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)))))
-;;;;;Old Def:
-;; (define-macro (push-not-null! lst obj)
-;; `(if (not (null? ,obj)) (push! ,lst ,obj)))
+;; 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.
+;; 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)
@@ -263,7 +238,7 @@
(res newat newbody)
(if (null? arglst)
(cggr accum 'cg-and `(reverse ,body) at) ;; base case
- (let ((mf (cg-match-func (car arglst) accum))) ;; match function
+ (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
@@ -274,7 +249,7 @@
((@@ (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.
+;; 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)
@@ -287,7 +262,7 @@
(res)
(if (null? arglst)
#f ;; base case
- (let ((mf (cg-match-func (car arglst) accum)))
+ (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))
@@ -298,7 +273,7 @@
(define (cg-body-test match accum str strlen at body)
(safe-bind
(at2-body2 at2 body2)
- (let ((mf (cg-match-func match accum)))
+ (let ((mf (peg-sexp-compile match accum)))
`(let ((,at2-body2 (,mf ,str ,strlen ,at)))
(if (or (not ,at2-body2) (= ,at (car ,at2-body2)))
#f
@@ -319,7 +294,6 @@
((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)
@@ -358,49 +332,32 @@
;;;;; 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.
-;;;;;Old Def:
-;; (define-macro (define-nonterm sym accum match)
-;; (define-nonterm-f sym accum match))
-;; (define (define-nonterm-f sym accum match)
-;; (safe-bind
-;; (res str strlen at body)
-;; (let ((match (cg-match-func match accum)))
-;; (let ((code
-;; `(lambda (,str ,strlen ,at)
-;; (let ((,res (,match ,str ,strlen ,at)))
-;; (if ,res
-;; (let ((,at (car ,res))
-;; (,body (cadr ,res)))
-;; ,(cond
-;; ((eq? accum 'name)
-;; `(list ,at ',sym))
-;; ((eq? accum 'all)
-;; `(list (car ,res)
-;; (cond
-;; ((not (list? ,body)) (list ',sym ,body))
-;; ((null? ,body) ',sym)
-;; ((symbol? (car ,body)) (list ',sym ,body))
-;; (#t (cons ',sym ,body)))))
-;; ((eq? accum 'none) `(list (car ,res) '()))
-;; (#t (begin `,res))))
-;; #f)))))
-;; (set-symbol-property! sym 'code code)
-;; `(define ,sym ,code)))))
(define-syntax define-nonterm
(lambda (x)
(syntax-case x ()
((_ sym accum match)
- (let ((matchf (cg-match-func (syntax->datum #'match)
+ (let ((matchf (peg-sexp-compile (syntax->datum #'match)
(syntax->datum #'accum)))
(symsym (syntax->datum #'sym))
- (accumsym (syntax->datum #'accum)))
+ (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
@@ -409,23 +366,35 @@
((eq? accumsym 'all)
`(list (car ,res)
(cond
- ((not (list? ,body)) (list ',symsym
,body))
+ ((not (list? ,body))
+ (list ',symsym ,body))
((null? ,body) ',symsym)
- ((symbol? (car ,body)) (list ',symsym
,body))
+ ((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 sym #,(datum->syntax x code))
+ (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
-;;;;;Old Def:
-;; (define-macro (get-code nonterm)
-;; `(pretty-print (symbol-property ',nonterm 'code)))
(define-syntax get-code
(lambda (x)
(syntax-case x ()
@@ -433,12 +402,46 @@
#`(pretty-print (symbol-property 'nonterm 'code))))))
;; Parses STRING using NONTERM
-(define (parse nonterm string)
- (let ((res (nonterm string (string-length string) 0)))
+(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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -453,7 +456,8 @@
(and (list? lst) (not (null? lst))
(andlst (map string? lst))))
-;; Groups all strings that are next to each other in 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
@@ -480,18 +484,30 @@
(if (single? res) (car res) res))
lst))
-;; Makes sure LST is a list.
+;; 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 tst to know when to stop instead of
-;; terminating on atoms.
-(define (flatmaster tst 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 (flatmaster tst x))) 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)
@@ -504,20 +520,28 @@
(define (trim-1chars str) (substring str 1 (- (string-length str) 1)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;; parse string PEGs using sexp PEGs
-;; grammar <- (nonterminal '<-' sp pattern)+
-;; pattern <- alternative ('/' sp alternative)*
-;; alternative <- ([!&]? sp suffix)+
-;; suffix <- primary ([*+?] sp)*
-;; primary <- '(' sp pattern ')' sp / '.' sp / literal / charclass /
nonterminal !'<-'
-;; literal <- ['] (!['] .)* ['] sp
-;; charclass <- '[' (!']' (charclass-range / charclass-single))* ']' sp
-;; charclass-range <- . '-' .
-;; charclass-single <- .
-;; nonterminal <- [a-zA-Z]+ sp
-;; sp <- [ \t\n]*
+;;;;; 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
@@ -543,21 +567,11 @@
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 peg-az peg-AZ) +) peg-sp))
(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") *))
-;;;;; Testing Code
-;; (define-nonterm tst all (body lit "a" +))
-;; (pretty-print (parse peg-grammar "as <- 'a'+ !.
-;; bs <- 'b'+ !.
-;; asorbs <- as / bs
-;; tst <- [a-z]+"
-;; ))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; PARSE STRING PEGS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -565,7 +579,7 @@
;; Pakes a string representing a PEG grammar and defines all the nonterminals
in
;; it as the associated PEGs.
(define (peg-parser str)
- (let ((parsed (parse peg-grammar str)))
+ (let ((parsed (peg-parse peg-grammar str)))
(if (not parsed)
(begin
;; (pretty-print "Invalid PEG grammar!\n")
@@ -576,9 +590,18 @@
lst)
((eq? (car lst) 'peg-grammar)
(cons 'begin (map (lambda (x) (peg-parse-nonterm x))
- (flatmaster (lambda (lst) (<= (depth lst) 2))
+ (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))
@@ -594,13 +617,13 @@
;; Parse a pattern.
(define (peg-parse-pattern lst)
(cons 'or (map peg-parse-alternative
- (flatmaster (lambda (x) (eq? (car x) 'peg-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
- (flatmaster (lambda (x) (or (string? (car x))
+ (context-flatten (lambda (x) (or (string? (car x))
(eq? (car x) 'peg-suffix)))
(cdr lst)))))
@@ -658,7 +681,7 @@
`(range ,(string-ref (cadr cc) 0) ,(string-ref (cadr cc) 2)))
((eq? (car cc) 'charclass-single)
(cadr cc))))
- (flatmaster
+ (context-flatten
(lambda (x) (or (eq? (car x) 'charclass-range)
(eq? (car x) 'charclass-single)))
(cdr lst)))))
@@ -678,40 +701,15 @@
(compressor (caddr lst)))
(#t (map compressor lst)))))
-;; Tests
-;; (define-nonterm t1 all
-;; (body lit (and (ignore "/") peg-sp peg-alternative) *))
-;; (define-nonterm t2 all (and (ignore "/") peg-sp peg-alternative))
-
-;; 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 < ']'
-")
-
-;; Convenience shortcut
-(define (pppp x) (pretty-print (peg-parser x)))
-
;; Builds a lambda-expressions for the pattern STR using accum.
-(define (pattern-builder str accum)
- (cg-match-func
- (compressor (peg-parse-pattern (peg:tree (parse peg-pattern str))))
+(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
@@ -730,82 +728,5 @@ RB < ']'
(if pm (substring (peg:string pm) (peg:start pm) (peg:end pm)) #f))
(define peg-record? (record-predicate prec))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;; USER-VISIBLE FUNCTIONS
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define peg-sexp-compile cg-match-func)
-(define peg-string-compile pattern-builder)
-
-(define context-flatten flatmaster)
-(define peg-parse parse)
-
-(define (keyword-flatten keyword-lst lst)
- (context-flatten
- (lambda (x)
- (if (or (not (list? x)) (null? x))
- #t
- (member (car x) keyword-lst)))
- lst))
-
-;; define-nonterm
-;; define-nonterm-f
-
-;; (define-macro (peg-find peg-matcher pattern)
-;; (peg-find-f peg-matcher pattern))
-;; (define-macro (peg-match peg-matcher pattern)
-;; (peg-find-f peg-matcher pattern))
-;; (define (peg-find-f peg-matcher pattern)
-;; (safe-bind
-;; (at strlen ret end match)
-;; (let ((cg-match-func
-;; (if (string? peg-matcher)
-;; (pattern-builder peg-matcher 'body)
-;; (cg-match-func peg-matcher 'body))))
-;; `(let ((,strlen (string-length ,pattern))
-;; (,at 0))
-;; (let ((,ret (until-works (or (>= ,at ,strlen)
-;; (,cg-match-func ,pattern ,strlen ,at))
-;; (set! ,at (+ ,at 1)))))
-;; (if (eq? ,ret #t)
-;; #f
-;; (let ((,end (car ,ret))
-;; (,match (cadr ,ret)))
-;; (list ,at ,end (string-collapse ,match)))))))))
-
-(define-syntax peg-match
- (lambda (x)
- (syntax-case x ()
- ((_ peg-matcher string)
- (let ((pmsym (syntax->datum #'peg-matcher)))
- (let ((cg-match-func
- (if (string? pmsym)
- (pattern-builder pmsym 'body)
- (cg-match-func pmsym 'body))))
- #`(let ((strlen (string-length string))
- (at 0))
- (let ((ret ((@@ (ice-9 peg) until-works)
- (or (>= at strlen)
- (#,(datum->syntax x cg-match-func)
- 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))))))))))))
-
-(define-syntax define-grammar
- (lambda (x)
- (syntax-case x ()
- ((_ str)
- (datum->syntax x (peg-parser (syntax->datum #'str)))))))
-(define define-grammar-f peg-parser)
-
-;; (define-macro (tst x)
-;; (compile (macroexpand (* x 2)) #:from 'tree-il))
-
)
diff --git a/test-suite/tests/peg.bench b/test-suite/tests/peg.bench
new file mode 100644
index 0000000..3b3716f
--- /dev/null
+++ b/test-suite/tests/peg.bench
@@ -0,0 +1,173 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; 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
diff --git a/test-suite/tests/peg.test b/test-suite/tests/peg.test
index cdcec3d..bd1ce51 100644
--- a/test-suite/tests/peg.test
+++ b/test-suite/tests/peg.test
@@ -1,10 +1,15 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; 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))
@@ -19,7 +24,9 @@
(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.
+;; 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)
@@ -33,7 +40,6 @@
(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)))
@@ -48,7 +54,11 @@
(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).
+;; 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"
@@ -153,6 +163,7 @@ SLASH < '/'")
(tree (bs "bb"))
(record? #t)))))
+;; PEG for parsing right-associative equations.
(define-grammar
"expr <- sum
sum <-- (product ('+' / '-') sum) / product
@@ -160,6 +171,7 @@ 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)
@@ -204,6 +216,7 @@ number <-- [0-9]+")
(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
@@ -211,6 +224,7 @@ 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)
@@ -262,226 +276,3 @@ number <-- [0-9]+")
(equal? (eq-parse "1+1/2*3+(1+1)/2")
'(+ (+ 1 (* (/ 1 2) 3)) (/ (+ 1 1) 2)))))
-;; (pretty-print (peg:tree (peg-parse passwd *etc-passwd*)))
-
-
-;; (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")
-
-;; (define-nonterm passwd body (peg "entry* !."))
-
-;; (define-nonterm passwd-file body
-;; (and (body lit (body ! "\n" 1) *)
-
-
-;; (tree-map
-;; (lambda (x)
-;; (let ((res (assoc x mappi
-
-;; (with-test-prefix "define-nonterm"
-;; (pass-if
-;; "abc"
-;; (and (define-nonterm abc all "abc") #t))
-;; (pass-if
-;; "abcs"
-;; (and (define-nonterm abcs all
-
-;; (define num "123")
-;; (define up "ABC")
-;; (define low "abc")
-;; (define (sa . args)
-;; (if (null? args)
-;; ""
-;; (if (number? (car args))
-;; (let ((res (apply sa (cdr args))))
-;; (append-times (car args) res))
-;; (string-append (car args) (apply sa (cdr args))))))
-;; (define (append-times num str)
-;; (if (<= num 0) "" (string-append str (append-times (- num 1) str))))
-
-;; (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))
-
-;; (define-macro (assert . tests)
-;; (apply assert-f tests))
-;; (define (assert-f . tests)
-;; (if (null? tests)
-;; #t
-;; (let ((try (car tests)))
-;; `(if (not ,try)
-;; (pretty-print '(,try failed))
-;; ,(apply assert-f (cdr tests))))))
-
-;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ;;;;;; Basic Character Classes
-;; (pretty-print "Testing basic character classes.")
-;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; (let ((str (sa num up low)))
-;; (let ((res (peg-match "[a-z]" str)))
-;; (assert
-;; (and
-;; (= (car res) (string-index str #\a))
-;; (= (- (cadr res) (car res)) 1)
-;; (string=? (caddr res) (string #\a)))))
-;; (let ((res (peg-match "[b-z]" str)))
-;; (assert
-;; (and
-;; (= (car res) (string-index str #\b))
-;; (= (- (cadr res) (car res)) 1)
-;; (string=? (caddr res) (string #\b)))))
-;; (let ((res (peg-match "[c-z]" str)))
-;; (assert
-;; (and
-;; (= (car res) (string-index str #\c))
-;; (= (- (cadr res) (car res)) 1)
-;; (string=? (caddr res) (string #\c)))))
-;; (let ((res (peg-match "[A-Z]" str)))
-;; (assert
-;; (and
-;; (= (car res) (string-index str #\A))
-;; (= (- (cadr res) (car res)) 1)
-;; (string=? (caddr res) (string #\A)))))
-;; (let ((res (peg-match "[B-Z]" str)))
-;; (assert
-;; (and
-;; (= (car res) (string-index str #\B))
-;; (= (- (cadr res) (car res)) 1)
-;; (string=? (caddr res) (string #\B)))))
-;; (let ((res (peg-match "[C-Z]" str)))
-;; (assert
-;; (and
-;; (= (car res) (string-index str #\C))
-;; (= (- (cadr res) (car res)) 1)
-;; (string=? (caddr res) (string #\C))))))
-
-;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ;;;;; Arithmetic Expressions
-;; (pretty-print "Testing arithmetic expression grammar.")
-;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; (define-grammar
-;; "Value <-- [0-9]+ / '(' Expr ')'
-;; Product <-- Value (('*' / '/') Value)*
-;; Sum <-- Product (('+' / '-') Product)*
-;; Expr <- Sum")
-
-;; (define (sum-parse lst)
-;; (cons '+
-;; (map
-;; (lambda (x)
-;; (if (eq? (car x) 'Product)
-;; (product-parse x)
-;; (list (string->symbol (car x)) (product-parse (cadr x)))))
-;; (context-flatten
-;; (lambda (x) (or (string? (car x)) (eq? (car x) 'Product)))
-;; (cdr lst)))))
-
-;; (define (product-parse lst)
-;; (cons '*
-;; (map
-;; (lambda (x)
-;; (if (eq? (car x) 'Value)
-;; (value-parse x)
-;; (list (string->symbol (car x)) (value-parse (cadr x)))))
-;; (context-flatten
-;; (lambda (x) (or (string? (car x)) (eq? (car x) 'Value)))
-;; (cdr lst)))))
-
-;; (define (value-parse lst)
-;; (if (> (length lst) 2)
-;; (sum-parse (caddr lst))
-;; (string->number (cadr lst))))
-
-;; (define (eq-eval eq)
-;; (eeval (sum-parse (cadr (peg-parse Expr eq)))))
-
-;; (assert
-;; (= (eq-eval "1+1") 2)
-;; (= (eq-eval "1+1*2") 3)
-;; (= (eq-eval "(1+1)*2") 4)
-;; (= (eq-eval "1+1/2") 3/2)
-;; (= (eq-eval "(1+1)/2") 1)
-;; (= (eq-eval "1-1") 0)
-;; (= (eq-eval "1-1*2") -1)
-;; (= (eq-eval "1-1/2") 1/2)
-;; (= (eq-eval "1+2+3") 6)
-;; (= (eq-eval "1+2-3") 0)
-;; (= (eq-eval "1-2+3") 2)
-;; (= (eq-eval "1+(2/(3+4)*5)-6*7+8") -221/7))
-
-;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ;;;;; Parsing Simplified C Functions
-;; (pretty-print "Testing simplified C function grammar...")
-;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; (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]*")
-
-;; (define func-square
-;; "
-;; int square(int a) {
-;; return a*a;
-;; }")
-
-;; (define func-mod
-;; "
-;; int mod(int a, int b) {
-;; int c = a/b;
-;; return a - b*c;
-;; }")
-
-;; ;; (pretty-print (peg-parse cfunc func-square))
-;; ;; (pretty-print (peg-parse cfunc func-mod))
-
-;; (assert
-;; (equal?
-;; (cadr (peg-parse cfunc func-square))
-;; '(cfunc (ctype "int")
-;; (cname "square")
-;; (cargs (carg (ctype "int") (cname "a")))
-;; (cbody (cstatement "return a*a"))))
-;; (equal?
-;; (cadr (peg-parse cfunc func-mod))
-;; '(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")))))
-
-;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ;;;;; Infinite Loop Tests
-;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; (define-nonterm itl all (body lit (body lit "a" *) *))
-;; (pretty-print "Running test that might freeze...")
-;; (if (assert (peg-parse itl "b")) (pretty-print "Test passed, no worries!"))
-
-;; ;; (pretty-print "\n***\nAll tests passed!\n***\n")
-
-;; (define-grammar
-;; "Begin <- '(*'
-;; End <- '*)'
-;; C <- Begin N* End
-;; N <- C / (!Begin !End Z)
-;; Z <- .")
-
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, mlucy, updated. release_1-9-11-163-gd0b4bf1,
Michael Lucy <=