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

peg: let cleanups

Browse source 
* module/ice-9/peg.scm (cg-string, cg-peg-any, cg-range): Remove some
  unnecessary lets.
This commit is contained in:
Noah Lavine 2011-02-01 15:15:54 -05:00 • committed by Andy Wingo
parent 18905baf6e
commit 9ca71e7b84
1 changed files with 64 additions and 95 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -80,7 +80,6 @@
;; The short name makes the formatting below much easier to read. ;; The short name makes the formatting below much easier to read.
(define cggl cg-generic-lambda) (define cggl cg-generic-lambda)
;; Optimizations for CG-GENERIC-RET below... ;; Optimizations for CG-GENERIC-RET below...
(define *op-known-single-body* '(cg-string cg-peg-any cg-range)) (define *op-known-single-body* '(cg-string cg-peg-any cg-range))
;; ...done with optimizations (could use more of these). ;; ...done with optimizations (could use more of these).
@ -122,43 +121,33 @@
;; Generates code that matches a particular string. ;; Generates code that matches a particular string.
;; E.g.: (cg-string syntax "abc" 'body) ;; E.g.: (cg-string syntax "abc" 'body)
(define (cg-string for-syntax match accum) (define (cg-string for-syntax match accum)
(let ((str (syntax str)) (let ((len (string-length match)))
(strlen (syntax strlen)) (cggl for-syntax #'str #'strlen #'at
(at (syntax at)) #`(if (string=? (substring str at (min (+ at #,len) strlen))
(len (string-length match))) #,match)
(cggl for-syntax str strlen at #,(cggr for-syntax accum 'cg-string match
#`(if (string=? (substring #,str #,at (min (+ #,at #,len) #,strlen)) #`(+ at #,len))
#,match) #f))))
#,(cggr for-syntax accum 'cg-string match
#`(+ #,at #,len))
#f))))
;; Generates code for matching any character. ;; Generates code for matching any character.
;; E.g.: (cg-peg-any syntax 'body) ;; E.g.: (cg-peg-any syntax 'body)
(define (cg-peg-any for-syntax accum) (define (cg-peg-any for-syntax accum)
(let ((str (syntax str)) (cggl for-syntax #'str #'strlen #'at
(strlen (syntax strlen)) (cggr for-syntax accum
(at (syntax at))) 'cg-peg-any #`(substring str at (+ at 1))
(cggl for-syntax str strlen at #`(+ at 1))))
(cggr for-syntax accum
'cg-peg-any #`(substring #,str #,at (+ #,at 1))
#`(+ #,at 1)))))
;; Generates code for matching a range of characters between start and end. ;; Generates code for matching a range of characters between start and end.
;; E.g.: (cg-range syntax #\a #\z 'body) ;; E.g.: (cg-range syntax #\a #\z 'body)
(define (cg-range for-syntax start end accum) (define (cg-range for-syntax start end accum)
(let ((str (syntax str)) (cggl for-syntax #'str #'strlen #'at
(strlen (syntax strlen)) #`(let ((c (string-ref str at)))
(at (syntax at)) (if (and
(c (syntax c))) (char>=? c #,start)
(cggl for-syntax str strlen at (char<=? c #,end))
#`(let ((#,c (string-ref #,str #,at))) #,(cggr for-syntax accum 'cg-range
(if (and #`(string c) #`(+ at 1))
(char>=? #,c #,start) #f))))
(char<=? #,c #,end))
#,(cggr for-syntax accum 'cg-range
#`(string #,c) #`(+ #,at 1))
#f)))))
;; Filters the accum argument to peg-sexp-compile for 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 ;; literals (since we don't want to tag them with their name if we're doing an
@ -229,69 +218,54 @@
;; Top-level function builder for AND. Reduces to a call to CG-AND-INT. ;; Top-level function builder for AND. Reduces to a call to CG-AND-INT.
(define (cg-and for-syntax arglst accum) (define (cg-and for-syntax arglst accum)
(let ((str (syntax str)) #`(lambda (str strlen at)
(strlen (syntax strlen)) (let ((body '()))
(at (syntax at)) #,(cg-and-int for-syntax arglst accum #'str #'strlen #'at #'body))))
(body (syntax body)))
#`(lambda (#,str #,strlen #,at)
(let ((#,body '()))
#,(cg-and-int for-syntax arglst accum str strlen at body)))))
;; Internal function builder for AND (calls itself). ;; Internal function builder for AND (calls itself).
(define (cg-and-int for-syntax arglst accum str strlen at body) (define (cg-and-int for-syntax arglst accum str strlen at body)
(let ((res (syntax res)) (if (null? arglst)
(newat (syntax newat)) (cggr for-syntax accum 'cg-and #`(reverse #,body) at) ;; base case
(newbody (syntax newbody))) (let ((mf (peg-sexp-compile for-syntax (car arglst) accum))) ;; match function
(if (null? arglst) #`(let ((res (#,mf #,str #,strlen #,at)))
(cggr for-syntax accum 'cg-and #`(reverse #,body) at) ;; base case (if (not res)
(let ((mf (peg-sexp-compile for-syntax (car arglst) accum))) ;; match function
#`(let ((#,res (#,mf #,str #,strlen #,at)))
(if (not #,res)
#f ;; if the match failed, the and failed #f ;; if the match failed, the and failed
;; otherwise update AT and BODY then recurse ;; otherwise update AT and BODY then recurse
(let ((#,newat (car #,res)) (let ((newat (car res))
(#,newbody (cadr #,res))) (newbody (cadr res)))
(set! #,at #,newat) (set! #,at newat)
((@@ (ice-9 peg) push-not-null!) #,body ((@@ (ice-9 peg) single-filter) #,newbody)) ((@@ (ice-9 peg) push-not-null!) #,body ((@@ (ice-9 peg) single-filter) newbody))
#,(cg-and-int for-syntax (cdr arglst) accum str strlen at body)))))))) #,(cg-and-int for-syntax (cdr arglst) accum str strlen at body)))))))
;; Top-level function builder for OR. Reduces to a call to CG-OR-INT. ;; Top-level function builder for OR. Reduces to a call to CG-OR-INT.
(define (cg-or for-syntax arglst accum) (define (cg-or for-syntax arglst accum)
(let ((str (syntax str)) #`(lambda (str strlen at)
(strlen (syntax strlen)) #,(cg-or-int for-syntax arglst accum #'str #'strlen #'at #'body)))
(at (syntax at))
(body (syntax body)))
#`(lambda (#,str #,strlen #,at)
#,(cg-or-int for-syntax arglst accum str strlen at body))))
;; Internal function builder for OR (calls itself). ;; Internal function builder for OR (calls itself).
(define (cg-or-int for-syntax arglst accum str strlen at body) (define (cg-or-int for-syntax arglst accum str strlen at body)
(let ((res (syntax res))) (if (null? arglst)
(if (null? arglst) #f ;; base case
#f ;; base case (let ((mf (peg-sexp-compile for-syntax (car arglst) accum)))
(let ((mf (peg-sexp-compile for-syntax (car arglst) accum))) #`(let ((res (#,mf #,str #,strlen #,at)))
#`(let ((#,res (#,mf #,str #,strlen #,at))) (if res ;; if the match succeeds, we're done
(if #,res ;; if the match succeeds, we're done #,(cggr for-syntax accum 'cg-or #`(cadr res) #`(car res))
#,(cggr for-syntax accum 'cg-or #`(cadr #,res) #`(car #,res)) #,(cg-or-int for-syntax (cdr arglst) accum str strlen at body))))))
#,(cg-or-int for-syntax (cdr arglst) accum str strlen at body)))))))
;; 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)
(let ((at2-body2 (syntax at2-body2)) (let ((mf (peg-sexp-compile for-syntax match accum)))
(at2 (syntax at2)) #`(let ((at2-body2 (#,mf #,str #,strlen #,at)))
(body2 (syntax body2))) (if (or (not at2-body2) (= #,at (car at2-body2)))
(let ((mf (peg-sexp-compile for-syntax match accum)))
#`(let ((#,at2-body2 (#,mf #,str #,strlen #,at)))
(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.
@ -305,17 +279,16 @@
;; 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)
(let ((success (syntax success))) #`(lambda (success)
#`(lambda (#,success)
#,(cond ((eq? type '!) #,(cond ((eq? type '!)
#`(if #,success #f #,(cggr 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 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 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.
@ -328,21 +301,17 @@
;; 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)
(let ((str (syntax str)) (let (; this doesn't work with regular syntax, and I'd really
(strlen (syntax strlen))
(at (syntax at))
; this next one doesn't work with (syntax at2), and I'd really
; like to know why. ; like to know why.
(at2 (datum->syntax for-syntax (gensym))) (at2 (datum->syntax for-syntax (gensym))))
(count (syntax count)) #`(lambda (str strlen at)
(body (syntax body))) (let ((#,at2 at) (count 0) (body '()))
#`(lambda (#,str #,strlen #,at) (while (and #,(cg-body-test for-syntax match accum
(let ((#,at2 #,at) (#,count 0) (#,body '())) #'str #'strlen at2 #'body)
(while (and #,(cg-body-test for-syntax match accum str strlen at2 body) (set! count (+ count 1))
(set! #,count (+ #,count 1)) #,(cg-body-more for-syntax num #'count)))
#,(cg-body-more for-syntax num count))) (#,(cg-body-ret for-syntax accum type 'cg-body #'body #'at at2)
(#,(cg-body-ret for-syntax accum type 'cg-body body at at2) #,(cg-body-success for-syntax num #'count))))))
#,(cg-body-success for-syntax num count))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; FOR DEFINING AND USING NONTERMINALS ;;;;; FOR DEFINING AND USING NONTERMINALS