[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-160-g6c
|
From: |
Michael Lucy |
|
Subject: |
[Guile-commits] GNU Guile branch, mlucy, updated. release_1-9-11-160-g6c22476 |
|
Date: |
Fri, 06 Aug 2010 06:30:42 +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=6c2247699d874b1ef583be7d0a772f3e12a171c1
The branch, mlucy has been updated
via 6c2247699d874b1ef583be7d0a772f3e12a171c1 (commit)
via a12363a1189fa04c924dd50694e28d5973eb69c0 (commit)
via 1da4553762f822aab6b9a3b939a2fa5d7b85532d (commit)
via 7ba66b4dd80f819008348270ca4761b85c0c803e (commit)
from a64c3d2e166236e82f266df6a1b7157f2c0ad80d (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 6c2247699d874b1ef583be7d0a772f3e12a171c1
Author: Michael Lucy <address@hidden>
Date: Fri Aug 6 01:29:23 2010 -0500
ready to push
commit a12363a1189fa04c924dd50694e28d5973eb69c0
Author: Michael Lucy <address@hidden>
Date: Fri Jul 30 02:32:10 2010 -0500
before playing
commit 1da4553762f822aab6b9a3b939a2fa5d7b85532d
Author: Michael Lucy <address@hidden>
Date: Thu Jul 29 02:24:45 2010 -0500
changed macros
commit 7ba66b4dd80f819008348270ca4761b85c0c803e
Author: Michael Lucy <address@hidden>
Date: Thu Jul 22 19:46:34 2010 -0500
before macro hell
-----------------------------------------------------------------------
Summary of changes:
module/ice-9/peg.scm | 513 ++++++++++++++++------------------
test-suite/tests/peg.test | 668 ++++++++++++++++++++++++++++++++-------------
2 files changed, 717 insertions(+), 464 deletions(-)
diff --git a/module/ice-9/peg.scm b/module/ice-9/peg.scm
index 5c07252..2765da8 100644
--- a/module/ice-9/peg.scm
+++ b/module/ice-9/peg.scm
@@ -1,12 +1,9 @@
(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)
- :export-syntax (until-works string-collapse single? push-not-null!
single-filter push!)
+ :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))
-(define (eeval exp)
- (eval exp (interaction-environment)))
(use-modules (ice-9 pretty-print))
-(use-modules (language tree-il))
(eval-when (compile load eval)
@@ -48,21 +45,33 @@
;; If TST is true, evaluate BODY and try again.
;; (turns out this is built-in, so I don't export it)
-(define-macro (while tst . body)
- `(do () ((not ,tst))
- ,@body))
+;;;;;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
-(define-macro (until-works action if-fails)
- (safe-bind
- (retval)
- `(let ((,retval ,action))
- (while (not ,retval)
- ,if-fails
- (set! ,retval ,action))
- ,retval)))
+;;;;;Old Def:
+;; (define-macro (until-works action if-fails)
+;; (safe-bind
+;; (retval)
+;; `(let ((,retval ,action))
+;; (while (not ,retval)
+;; ,if-fails
+;; (set! ,retval ,action))
+;; ,retval)))
+(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
@@ -70,12 +79,24 @@
;; return #t if the list has only one element
;; (calling length all the time on potentially long lists was really slow)
-(define-macro (single? lst)
- `(and (list? ,lst) (not (null? ,lst)) (null? (cdr ,lst))))
+;;;;;Old Def:
+;; (define-macro (single? lst)
+;; `(and (list? ,lst) (not (null? ,lst)) (null? (cdr ,lst))))
+(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-macro (push! lst obj)
- `(set! ,lst (cons ,obj ,lst)))
+;;;;;Old Def:
+;; (define-macro (push! lst obj)
+;; `(set! ,lst (cons ,obj ,lst)))
+(define-syntax push!
+ (lambda (x)
+ (syntax-case x ()
+ ((_ lst obj)
+ #'(set! lst (cons obj lst))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; CODE GENERATORS
@@ -119,7 +140,7 @@
`(list ,at ,body))
(#t `(list ,at
(cond
- ((single? ,body) (car ,body))
+ (((@@ (ice-9 peg) single?) ,body) (car ,body))
(#t ,body))))))
((eq? accum 'none)
`(list ,at '()))
@@ -212,9 +233,21 @@
(#t (error-val `(cg-match-func-error-3 ,match ,accum)))))
;;;;; Convenience macros for making sure things come out in a readable form.
-(define-macro (single-filter sym) `(if (single? ,sym) (car ,sym) ,sym))
-(define-macro (push-not-null! lst obj)
- `(if (not (null? ,obj)) (push! ,lst ,obj)))
+;;;;;Old Def:
+;; (define-macro (single-filter sym) `(if (single? ,sym) (car ,sym) ,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)))
+(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.
(define (cg-and arglst accum)
@@ -238,7 +271,7 @@
(let ((,newat (car ,res))
(,newbody (cadr ,res)))
(set! ,at ,newat)
- (push-not-null! ,body (single-filter ,newbody))
+ ((@@ (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.
@@ -272,7 +305,9 @@
(let ((,at2 (car ,at2-body2))
(,body2 (cadr ,at2-body2)))
(set! ,at ,at2)
- (push-not-null! ,body (single-filter ,body2))
+ ((@@ (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
@@ -324,47 +359,85 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Defines a new nonterminal symbol accumulating with ACCUM.
-(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 (if (string? match)
- ;; (pattern-builder match accum)
- ;; (cg-match-func match accum))))
-
- (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)))))
+;;;;;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)
+ (syntax->datum #'accum)))
+ (symsym (syntax->datum #'sym))
+ (accumsym (syntax->datum #'accum)))
+ (let ((code
+ (safe-bind
+ (str strlen at res body)
+ `(lambda (,str ,strlen ,at)
+ (let ((,res (,matchf ,str ,strlen ,at)))
+ (if ,res
+ (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))))
+ #f))))))
+ #`(begin
+ (define sym #,(datum->syntax x code))
+ (set-symbol-property!
+ 'sym 'code #,(datum->syntax x (list 'quote code)))
+ sym)))))))
;; Gets the code corresponding to NONTERM
-(define-macro (get-code nonterm)
- `(pretty-print (symbol-property ',nonterm 'code)))
+;;;;;Old Def:
+;; (define-macro (get-code nonterm)
+;; `(pretty-print (symbol-property ',nonterm 'code)))
+(define-syntax get-code
+ (lambda (x)
+ (syntax-case x ()
+ ((_ nonterm)
+ #`(pretty-print (symbol-property 'nonterm 'code))))))
;; Parses STRING using NONTERM
(define (parse nonterm string)
- (string-collapse (nonterm string (string-length string) 0)))
+ (let ((res (nonterm string (string-length string) 0)))
+ (if (not res)
+ #f
+ (make-prec 0 (car res) string (string-collapse (cadr res))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; POST-PROCESSING FUNCTIONS (TO CANONICALIZE MATCH TREES)
@@ -418,7 +491,7 @@
lst
(if (tst lst)
(list lst)
- (apply append (map (lambda (x) (mklst (flatmaster tst x)) lst))))))
+ (apply append (map (lambda (x) (mklst (flatmaster tst x))) lst)))))
;; Gets the left-hand depth of a list.
(define (depth lst)
@@ -473,7 +546,7 @@
;; (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)) +) peg-sp))
+ (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") *))
@@ -495,9 +568,9 @@
(let ((parsed (parse peg-grammar str)))
(if (not parsed)
(begin
- (pretty-print "Invalid PEG grammar!\n")
+ ;; (pretty-print "Invalid PEG grammar!\n")
#f)
- (let ((lst (cadr parsed)))
+ (let ((lst (peg:tree parsed)))
(cond
((or (not (list? lst)) (null? lst))
lst)
@@ -526,7 +599,10 @@
;; Parse an alternative.
(define (peg-parse-alternative lst)
- (cons 'and (map peg-parse-body (cdr lst))))
+ (cons 'and (map peg-parse-body
+ (flatmaster (lambda (x) (or (string? (car x))
+ (eq? (car x) 'peg-suffix)))
+ (cdr lst)))))
;; Parse a body.
(define (peg-parse-body lst)
@@ -609,17 +685,20 @@
;; Grammar for PEGs in PEG grammar.
(define peg-as-peg
-"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 <- '[' (!']' (CCrange / CCsingle))* ']' sp
-CCrange <- . '-' .
-CCsingle <- .
-nonterminal <- [a-zA-Z]+ sp
-sp <- [ \t\n]*
+"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
@@ -628,10 +707,30 @@ sp <- [ \t\n]*
;; Builds a lambda-expressions for the pattern STR using accum.
(define (pattern-builder str accum)
(cg-match-func
- (compressor (peg-parse-pattern (cadr (parse peg-pattern str))))
+ (compressor (peg-parse-pattern (peg:tree (parse peg-pattern str))))
accum))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; PMATCH STRUCTURE MUNGING
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; USER-VISIBLE FUNCTIONS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -641,202 +740,72 @@ sp <- [ \t\n]*
(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-macro (define-grammar str)
- (peg-parser str))
+;; (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))
+;; (define-macro (tst x)
+;; (compile (macroexpand (* x 2)) #:from 'tree-il))
+
+)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;; OLD CODE
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; (define (match-func match accum)
-;; (cond ((string? match)
-;; (let ((len (string-length match)))
-;; `(lambda (str strlen at)
-;; (if (>= at strlen)
-;; #f
-;; (if (string=? (substring str at (min (+ at ,len) strlen))
-;; ,match)
-;; (list (+ at ,len) ,match)
-;; #f)))))
-;; ((symbol? match)
-;; (cond
-;; ((eq? match 'peg-any)
-;; `(lambda (str strlen at)
-;; (if (>= at strlen)
-;; #f
-;; (list (+ at 1) (substring str at (+ at 1))))))
-;; ((eq? match 'peg-az)
-;; (match-func '(range #\a #\z) accum))
-;; ((eq? match 'peg-AZ)
-;; (match-func '(range #\A #\Z) accum))
-;; (#t match)))
-;; ((or (not (list? match)) (null? match))
-;; (begin
-;; (pretty-print `(fail-match-func ,match ,accum))
-;; `fail-match-func))
-;; ((eq? (car match) 'range)
-;; `(lambda (str strlen at)
-;; (if (>= at strlen)
-;; #f
-;; (let ((c (string-ref str at)))
-;; (if (and (char>=? c ,(cadr match))
-;; (char<=? c ,(caddr match)))
-;; (list (+ at 1) (string c))
-;; #f)))))
-;; ((eq? (car match) 'ignore)
-;; `(lambda (str strlen at)
-;; (let ((res (,(match-func (cadr match) accum) str strlen at)))
-;; (if res
-;; (list (car res) '())
-;; #f))))
-;; ((eq? (car match) 'and)
-;; (build-and-top (cdr match)))
-;; ((eq? (car match) 'or)
-;; (build-or-top (cdr match)))
-;; ((eq? (car match) 'body)
-;; (if (not (= (length match) 4))
-;; (begin
-;; (pretty-print `(fail-match-func-2 ,match ,accum))
-;; `fail-match-func-2)
-;; (apply build-lambda (cdr match))))
-;; (#t (begin
-;; (pretty-print `(fail-match-func-3 ,match ,accum))
-;; `fail-match-func-3))))
-
-;; (define (tst-func match strsym strlensym atsym bodysym)
-;; (let ((at2-body2 (gensym))
-;; (at2 (gensym))
-;; (body2 (gensym)))
-;; `(let ((,at2-body2 (,(match-func match #f) ,strsym ,strlensym ,atsym)))
-;; (if ,at2-body2
-;; (let ((,at2 (car ,at2-body2))
-;; (,body2 (cadr ,at2-body2)))
-;; (begin
-;; (set! ,atsym ,at2)
-;; (if (not (null? ,body2))
-;; (push! ,bodysym
-;; (if (single? ,body2) (car ,body2) ,body2)))
-;; #t))
-;; #f))))
-
-;; (define (check-func num countsym)
-;; (cond ((number? num) `(< ,countsym ,num))
-;; ((eq? num '+) #t)
-;; ((eq? num '*) #t)
-;; ((eq? num '?) `(< ,countsym 1))
-;; (#t `(check-func-error ,num ,countsym))))
-
-;; (define (success-check-func num countsym)
-;; (cond ((number? num) `(= ,countsym ,num))
-;; ((eq? num '+) `(>= ,countsym 1))
-;; ((eq? num '*) #t)
-;; ((eq? num '?) `(<= ,countsym 1))
-;; (#t `(success-check-func-error ,num))))
-
-;; (define (ret-func type atsym at2sym bodysym)
-;; `(lambda (success)
-;; ,(cond ((eq? type '!)
-;; `(if success #f (list ,atsym '())))
-;; ((eq? type '&)
-;; `(if success (list ,atsym '()) #f))
-;; ((eq? type 'lit)
-;; `(if success (list ,at2sym (reverse ,bodysym)) #f))
-;; (#t `(ret-func-error ,type ,atsym ,at2sym ,bodysym)))))
-
-;; (define (build-lambda type match num)
-;; (let ((tst (tst-func match 'str 'strlen 'at2 'body))
-;; (check (check-func num 'count))
-;; (ret (ret-func type 'at 'at2 'body))
-;; (success-check (success-check-func num 'count)))
-;; `(lambda (str strlen at)
-;; (let ((at2 at) (count 0) (body '()))
-;; (while (and ,tst
-;; (set! count (+ count 1))
-;; ,check))
-;; (,ret ,success-check)))))
-
-;; (define (build-and-top arglst)
-;; `(lambda (str strlen at)
-;; (let ((body '()))
-;; ,(build-and arglst 'str 'strlen 'at 'body))))
-
-;; (define (build-and arglst strsym strlensym atsym bodysym)
-;; (if (null? arglst)
-;; `(list ,atsym (reverse ,bodysym))
-;; (let ((mf (match-func (car arglst) #f)))
-;; `(let ((res (,mf ,strsym ,strlensym ,atsym)))
-;; (if (not res)
-;; #f
-;; (begin
-;; (set! ,atsym (car res))
-;; (if (not (null? (cadr res)))
-;; (push! ,bodysym
-;; (if (single? (cadr res)) (caadr res) (cadr
res))))
-;; ,(build-and (cdr arglst) strsym strlensym atsym
bodysym)))))))
-
-;; (define (build-or-top arglst)
-;; `(lambda (str strlen at)
-;; (let ((body '()))
-;; ,(build-or arglst 'str 'strlen 'at 'body))))
-
-;; (define (build-or arglst strsym strlensym atsym bodysym)
-;; (if (null? arglst)
-;; #f
-;; (let ((mf (match-func (car arglst) #f)))
-;; `(let ((res (,mf ,strsym ,strlensym ,atsym)))
-;; (if res
-;; (list (car res) (cadr res))
-;; ,(build-or (cdr arglst) strsym strlensym atsym bodysym))))))
-
-;; (define-macro (quoter q) `',q)
-
-;; (define-nonterm abc (body lit "abc" 1))
-;; (define-nonterm def (body lit "def" 1))
-;; (define-nonterm abcplus (body lit abc +))
-;; ;; (pretty-print (match-func '(and (body lit "abc" 1) (body lit "def" 1))))
-;; (define-nonterm abcdef (and abc def))
-;; (define-nonterm abcordef (or abc def))
-
-;; (define-nonterm c-begin "(*")
-;; (define-nonterm c-end "*)")
-;; (define-nonterm c-c (and c-begin (body lit c-n *) c-end))
-;; (define-nonterm c-n (or c-c (and (body ! c-begin 1) (body ! c-end 1) c-z)))
-;; (define-nonterm c-z "a")
-
-;; (define-nonterm c-s (and (body & (and c-a "c") 1)
-;; (body lit "a" +)
-;; c-b
-;; (body ! (or "a" "b" "c") 1)))
-;; (define-nonterm c-a (and "a" (body lit c-a ?) "b"))
-;; (define-nonterm c-b (and "b" (body lit c-b ?) "c"))
-
-)
\ No newline at end of file
diff --git a/test-suite/tests/peg.test b/test-suite/tests/peg.test
index 966000b..cdcec3d 100644
--- a/test-suite/tests/peg.test
+++ b/test-suite/tests/peg.test
@@ -1,203 +1,487 @@
+(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)))))))
-(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-find "[a-z]" str)))
- (assert
- (and
- (= (car res) (string-index str #\a))
- (= (- (cadr res) (car res)) 1)
- (string=? (caddr res) (string #\a)))))
- (let ((res (peg-find "[b-z]" str)))
- (assert
- (and
- (= (car res) (string-index str #\b))
- (= (- (cadr res) (car res)) 1)
- (string=? (caddr res) (string #\b)))))
- (let ((res (peg-find "[c-z]" str)))
- (assert
- (and
- (= (car res) (string-index str #\c))
- (= (- (cadr res) (car res)) 1)
- (string=? (caddr res) (string #\c)))))
- (let ((res (peg-find "[A-Z]" str)))
- (assert
- (and
- (= (car res) (string-index str #\A))
- (= (- (cadr res) (car res)) 1)
- (string=? (caddr res) (string #\A)))))
- (let ((res (peg-find "[B-Z]" str)))
- (assert
- (and
- (= (car res) (string-index str #\B))
- (= (- (cadr res) (car res)) 1)
- (string=? (caddr res) (string #\B)))))
- (let ((res (peg-find "[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.")
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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
- "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...")
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ "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)))))
(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")
+ "expr <- sum
+sum <-- (product ('+' / '-') sum) / product
+product <-- (value ('*' / '/') product) / value
+value <-- number / '(' expr ')'
+number <-- [0-9]+")
+
+(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))))))
(define-grammar
- "Begin <- '(*'
-End <- '*)
-C <- Begin N* End
-N <- C / (!Begin !End Z)
-Z <- .")
\ No newline at end of file
+ "expr <- sum
+sum <-- (product ('+' / '-'))* product
+product <-- (value ('*' / '/'))* value
+value <-- number / '(' expr ')'
+number <-- [0-9]+")
+
+(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)))))
+
+;; (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-160-g6c22476,
Michael Lucy <=