mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 13:30:26 +02:00
Code Activity

peg: more helpers returning syntax

Browse source 
* module/ice-9/peg.scm (cg-body, cg-body-success, cg-body-more)
  (cg-body-ret): Return syntax instead of s-expressions.
This commit is contained in:
Noah Lavine 2011-02-01 10:36:08 -05:00 • committed by Andy Wingo
parent 8e8de46ec6
commit 84cb143eb4
1 changed files with 38 additions and 33 deletions
Download patch file Download diff file Expand all files Collapse all files

71
module/ice-9/peg.scm
View file

@ -351,66 +351,71 @@
;; Returns a block of code that tries to match MATCH, and on success updates AT ;; 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. ;; and BODY, return #f on failure and #t on success.
(define (cg-body-test for-syntax match accum str strlen at body) (define (cg-body-test for-syntax match accum str strlen at body)
(safe-bind (let ((at2-body2 (syntax at2-body2))
(at2-body2 at2 body2) (at2 (syntax at2))
(let ((mf (syntax->datum (body2 (syntax body2)))
(peg-sexp-compile for-syntax match accum)))) (let ((mf (peg-sexp-compile for-syntax match accum)))
`(let ((,at2-body2 (,mf ,str ,strlen ,at))) #`(let ((#,at2-body2 (#,mf #,str #,strlen #,at)))
(if (or (not ,at2-body2) (= ,at (car ,at2-body2))) (if (or (not #,at2-body2) (= #,at (car #,at2-body2)))
#f #f
(let ((,at2 (car ,at2-body2)) (let ((#,at2 (car #,at2-body2))
(,body2 (cadr ,at2-body2))) (#,body2 (cadr #,at2-body2)))
(set! ,at ,at2) (set! #,at #,at2)
((@@ (ice-9 peg) push-not-null!) ((@@ (ice-9 peg) push-not-null!)
,body #,body
((@@ (ice-9 peg) single-filter) ,body2)) ((@@ (ice-9 peg) single-filter) #,body2))
#t)))))) #t))))))
;; Returns a block of code that sees whether NUM wants us to try and match more ;; Returns a block of code that sees whether NUM wants us to try and match more
;; given that we've already matched COUNT. ;; given that we've already matched COUNT.
(define (cg-body-more for-syntax num count) (define (cg-body-more for-syntax num count)
(cond ((number? num) `(< ,count ,num)) (cond ((number? num) #`(< #,count #,(datum->syntax for-syntax num)))
((eq? num '+) #t) ((eq? num '+) #t)
((eq? num '*) #t) ((eq? num '*) #t)
((eq? num '?) `(< ,count 1)) ((eq? num '?) #`(< #,count 1))
(#t (error-val `(cg-body-more-error ,num ,count))))) (#t (error-val `(cg-body-more-error ,num ,count)))))
;; Returns a function that takes a paramter indicating whether or not the match ;; Returns a function that takes a paramter indicating whether or not the match
;; was succesful and returns what the body expression should return. ;; was succesful and returns what the body expression should return.
(define (cg-body-ret for-syntax accum type name body at at2) (define (cg-body-ret for-syntax accum type name body at at2)
(safe-bind (let ((success (syntax success)))
(success) #`(lambda (#,success)
`(lambda (,success) #,(cond ((eq? type '!)
,(cond ((eq? type '!) #`(if #,success #f #,(cggr-syn for-syntax accum name ''() at)))
`(if ,success #f ,(cggr for-syntax accum name ''() at)))
((eq? type '&) ((eq? type '&)
`(if ,success ,(cggr for-syntax accum name ''() at) #f)) #`(if #,success #,(cggr-syn for-syntax accum name ''() at) #f))
((eq? type 'lit) ((eq? type 'lit)
`(if ,success #`(if #,success
,(cggr for-syntax accum name `(reverse ,body) at2) #f)) #,(cggr-syn for-syntax accum name #`(reverse #,body) at2) #f))
(#t (error-val (#t (error-val
`(cg-body-ret-error ,type ,accum ,name ,body ,at ,at2))))))) `(cg-body-ret-error ,type ,accum ,name ,body ,at ,at2)))))))
;; Returns a block of code that sees whether COUNT satisfies the constraints of ;; Returns a block of code that sees whether COUNT satisfies the constraints of
;; NUM. ;; NUM.
(define (cg-body-success for-syntax num count) (define (cg-body-success for-syntax num count)
(cond ((number? num) `(= ,count ,num)) (cond ((number? num) #`(= #,count #,num))
((eq? num '+) `(>= ,count 1)) ((eq? num '+) #`(>= #,count 1))
((eq? num '*) #t) ((eq? num '*) #t)
((eq? num '?) `(<= ,count 1)) ((eq? num '?) #`(<= #,count 1))
(#t `(cg-body-success-error ,num)))) (#t `(cg-body-success-error ,num))))
;; Returns a function that parses a BODY element. ;; Returns a function that parses a BODY element.
(define (cg-body for-syntax accum type match num) (define (cg-body for-syntax accum type match num)
(safe-bind (let ((str (syntax str))
(str strlen at at2 count body) (strlen (syntax strlen))
`(lambda (,str ,strlen ,at) (at (syntax at))
(let ((,at2 ,at) (,count 0) (,body '())) ; this next one doesn't work with (syntax at2), and I'd really
(while (and ,(cg-body-test for-syntax match accum str strlen at2 body) ; like to know why.
(set! ,count (+ ,count 1)) (at2 (datum->syntax for-syntax (gensym)))
,(cg-body-more for-syntax num count))) (count (syntax count))
(,(cg-body-ret for-syntax accum type 'cg-body body at at2) (body (syntax body)))
,(cg-body-success for-syntax num count)))))) #`(lambda (#,str #,strlen #,at)
(let ((#,at2 #,at) (#,count 0) (#,body '()))
(while (and #,(cg-body-test for-syntax match accum str strlen at2 body)
(set! #,count (+ #,count 1))
#,(cg-body-more for-syntax num count)))
(#,(cg-body-ret for-syntax accum type 'cg-body body at at2)
#,(cg-body-success for-syntax num count))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; FOR DEFINING AND USING NONTERMINALS ;;;;; FOR DEFINING AND USING NONTERMINALS