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

peg: compilers return syntax instead of s-expressions

Browse source 
* module/ice-9/peg.scm (peg-sexp-compile, peg-string-compile): Return
  syntax instead of s-expressions.
This commit is contained in:
Noah Lavine 2011-01-29 14:12:38 -05:00 • committed by Andy Wingo
parent ccab173a5b
commit fe50d7ee1a
1 changed files with 15 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -211,6 +211,7 @@
;; Takes an arbitrary expressions and accumulation variable, then parses it. ;; Takes an arbitrary expressions and accumulation variable, then parses it.
;; E.g.: (peg-sexp-compile syntax '(and "abc" (or "-" (range #\a #\z))) 'all) ;; E.g.: (peg-sexp-compile syntax '(and "abc" (or "-" (range #\a #\z))) 'all)
(define (peg-sexp-compile for-syntax match accum) (define (peg-sexp-compile for-syntax match accum)
(datum->syntax for-syntax
(cond (cond
((string? match) (cg-string for-syntax match (baf accum))) ((string? match) (cg-string for-syntax match (baf accum)))
((symbol? match) ;; either peg-any or a nonterminal ((symbol? match) ;; either peg-any or a nonterminal
@ -225,18 +226,18 @@
((eq? (car match) 'range) ;; range of characters (e.g. [a-z]) ((eq? (car match) 'range) ;; range of characters (e.g. [a-z])
(cg-range for-syntax (cadr match) (caddr match) (baf accum))) (cg-range for-syntax (cadr match) (caddr match) (baf accum)))
((eq? (car match) 'ignore) ;; match but don't parse ((eq? (car match) 'ignore) ;; match but don't parse
(peg-sexp-compile for-syntax (cadr match) 'none)) (syntax->datum (peg-sexp-compile for-syntax (cadr match) 'none)))
((eq? (car match) 'capture) ;; parse ((eq? (car match) 'capture) ;; parse
(peg-sexp-compile for-syntax (cadr match) 'body)) (syntax->datum (peg-sexp-compile for-syntax (cadr match) 'body)))
((eq? (car match) 'peg) ;; embedded PEG string ((eq? (car match) 'peg) ;; embedded PEG string
(peg-string-compile for-syntax (cadr match) (baf accum))) (syntax->datum (peg-string-compile for-syntax (cadr match) (baf accum))))
((eq? (car match) 'and) (cg-and for-syntax (cdr match) (baf accum))) ((eq? (car match) 'and) (cg-and for-syntax (cdr match) (baf accum)))
((eq? (car match) 'or) (cg-or for-syntax (cdr match) (baf accum))) ((eq? (car match) 'or) (cg-or for-syntax (cdr match) (baf accum)))
((eq? (car match) 'body) ((eq? (car match) 'body)
(if (not (= (length match) 4)) (if (not (= (length match) 4))
(error-val `(peg-sexp-compile-error-2 ,match ,accum)) (error-val `(peg-sexp-compile-error-2 ,match ,accum))
(apply cg-body for-syntax (cons (baf accum) (cdr match))))) (apply cg-body for-syntax (cons (baf accum) (cdr match)))))
(#t (error-val `(peg-sexp-compile-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. ;;;;; Convenience macros for making sure things come out in a readable form.
;; If SYM is a list of one element, return (car SYM), else return SYM. ;; If SYM is a list of one element, return (car SYM), else return SYM.
@ -266,7 +267,8 @@
(res newat newbody) (res newat newbody)
(if (null? arglst) (if (null? arglst)
(cggr for-syntax accum 'cg-and `(reverse ,body) at) ;; base case (cggr for-syntax accum 'cg-and `(reverse ,body) at) ;; base case
(let ((mf (peg-sexp-compile for-syntax (car arglst) accum))) ;; match function (let ((mf (syntax->datum
(peg-sexp-compile for-syntax (car arglst) accum)))) ;; match function
`(let ((,res (,mf ,str ,strlen ,at))) `(let ((,res (,mf ,str ,strlen ,at)))
(if (not ,res) (if (not ,res)
#f ;; if the match failed, the and failed #f ;; if the match failed, the and failed
@ -290,7 +292,8 @@
(res) (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 (syntax->datum
(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))
@ -301,7 +304,8 @@
(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 (safe-bind
(at2-body2 at2 body2) (at2-body2 at2 body2)
(let ((mf (peg-sexp-compile for-syntax match accum))) (let ((mf (syntax->datum
(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
@ -369,8 +373,8 @@
;; the point of diminishing returns on my box. ;; the point of diminishing returns on my box.
(define *cache-size* 512) (define *cache-size* 512)
(define (syntax-for-non-cache-case for-syntax matchf accumsym s-syn) (define (syntax-for-non-cache-case for-syntax matchf-syn accumsym s-syn)
(let ((matchf-syn (datum->syntax for-syntax matchf))) ; (let ((matchf-syn (datum->syntax for-syntax matchf)))
#`(lambda (str strlen at) #`(lambda (str strlen at)
(let ((res (#,matchf-syn str strlen at))) (let ((res (#,matchf-syn str strlen at)))
;; Try to match the nonterminal. ;; Try to match the nonterminal.
@ -394,7 +398,7 @@
((eq? accumsym 'none) #`(list (car res) '())) ((eq? accumsym 'none) #`(list (car res) '()))
(#t #`(begin res)))) (#t #`(begin res))))
;; If we didn't match, just return false. ;; If we didn't match, just return false.
#f))))) #f))))
;; Defines a new nonterminal symbol accumulating with ACCUM. ;; Defines a new nonterminal symbol accumulating with ACCUM.
(define-syntax define-nonterm (define-syntax define-nonterm
@ -462,7 +466,7 @@
(at 0)) (at 0))
(let ((ret ((@@ (ice-9 peg) until-works) (let ((ret ((@@ (ice-9 peg) until-works)
(or (>= at strlen) (or (>= at strlen)
(#,(datum->syntax x peg-sexp-compile) (#,peg-sexp-compile
string strlen at)) string strlen at))
(set! at (+ at 1))))) (set! at (+ at 1)))))
(if (eq? ret #t) ;; (>= at strlen) succeeded (if (eq? ret #t) ;; (>= at strlen) succeeded