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

Make Macros Hygienic

Browse source 
* modules/ice-9/peg.scm: convert the unhygienic macros that generate code
    for string PEGs to use hygiene.
This commit is contained in:
Noah Lavine 2011-03-05 22:37:11 -05:00 • committed by Andy Wingo
parent 86849e2c19
commit 00923497d2
1 changed files with 73 additions and 56 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -294,7 +294,7 @@ RB < ']'
;; Pakes a string representing a PEG grammar and defines all the nonterminals in
;; it as the associated PEGs.
(define (peg-parser str)
(define (peg-parser str for-syntax)
(let ((parsed (peg-parse peg-grammar str)))
(if (not parsed)
(begin
@ -305,7 +305,8 @@ RB < ']'
((or (not (list? lst)) (null? lst))
lst)
((eq? (car lst) 'peg-grammar)
(cons 'begin (map (lambda (x) (peg-nonterm->defn x))
#`(begin
#,@(map (lambda (x) (peg-nonterm->defn x for-syntax))
(context-flatten (lambda (lst) (<= (depth lst) 2))
(cdr lst))))))))))
@ -315,88 +316,101 @@ RB < ']'
(lambda (x)
(syntax-case x ()
((_ str)
(datum->syntax x (peg-parser (syntax->datum #'str)))))))
(peg-parser (syntax->datum #'str) x)))))
(define define-grammar-f peg-parser)
;; Parse a nonterminal and pattern listed in LST.
(define (peg-nonterm->defn lst)
(let ((nonterm (car lst))
(define (peg-nonterm->defn lst for-syntax)
(let* ((nonterm (car lst))
(grabber (cadr lst))
(pattern (caddr lst)))
`(define-nonterm ,(string->symbol (cadr nonterm))
,(cond
((string=? grabber "<--") 'all)
((string=? grabber "<-") 'body)
(else 'none))
,(compressor (peg-pattern->defn pattern)))))
(pattern (caddr lst))
(nonterm-name (datum->syntax for-syntax
(string->symbol (cadr nonterm)))))
#`(define-nonterm #,nonterm-name
#,(cond
((string=? grabber "<--") (datum->syntax for-syntax 'all))
((string=? grabber "<-") (datum->syntax for-syntax 'body))
(else (datum->syntax for-syntax 'none)))
#,(compressor (peg-pattern->defn pattern for-syntax) for-syntax))))
;; Parse a pattern.
(define (peg-pattern->defn lst)
(cons 'or (map peg-alternative->defn
(define (peg-pattern->defn lst for-syntax)
#`(or #,@(map (lambda (x) (peg-alternative->defn x for-syntax))
(context-flatten (lambda (x) (eq? (car x) 'peg-alternative))
(cdr lst)))))
;; Parse an alternative.
(define (peg-alternative->defn lst)
(cons 'and (map peg-body->defn
(define (peg-alternative->defn lst for-syntax)
#`(and #,@(map (lambda (x) (peg-body->defn x for-syntax))
(context-flatten (lambda (x) (or (string? (car x))
(eq? (car x) 'peg-suffix)))
(cdr lst)))))
;; Parse a body.
(define (peg-body->defn lst)
(define (peg-body->defn lst for-syntax)
(let ((suffix '())
(front 'lit))
(front (datum->syntax for-syntax 'lit)))
(cond
((eq? (car lst) 'peg-suffix)
(set! suffix lst))
((string? (car lst))
(begin (set! front (string->symbol (car lst)))
(begin (set! front (datum->syntax for-syntax
(string->symbol (car lst))))
(set! suffix (cadr lst))))
(else `(peg-parse-body-fail ,lst)))
`(body ,front ,@(peg-suffix->defn suffix))))
#`(body #,front #,@(peg-suffix->defn
suffix
for-syntax))))
;; Parse a suffix.
(define (peg-suffix->defn lst)
(list (peg-primary->defn (cadr lst))
(if (null? (cddr lst))
(define (peg-suffix->defn lst for-syntax)
#`(#,(peg-primary->defn (cadr lst) for-syntax)
#,(if (null? (cddr lst))
1
(string->symbol (caddr lst)))))
(datum->syntax for-syntax (string->symbol (caddr lst))))))
;; Parse a primary.
(define (peg-primary->defn lst)
(define (peg-primary->defn lst for-syntax)
(let ((el (cadr lst)))
(cond
((list? el)
(cond
((eq? (car el) 'peg-literal)
(peg-literal->defn el))
(peg-literal->defn el for-syntax))
((eq? (car el) 'peg-charclass)
(peg-charclass->defn el))
(peg-charclass->defn el for-syntax))
((eq? (car el) 'peg-nonterminal)
(string->symbol (cadr el)))))
(datum->syntax for-syntax (string->symbol (cadr el))))))
((string? el)
(cond
((equal? el "(")
(peg-pattern->defn (caddr lst)))
(peg-pattern->defn (caddr lst) for-syntax))
((equal? el ".")
'peg-any)
(else `(peg-parse-any unknown-string ,lst))))
(else `(peg-parse-any unknown-el ,lst)))))
(datum->syntax for-syntax 'peg-any))
(else (datum->syntax for-syntax
`(peg-parse-any unknown-string ,lst)))))
(else (datum->syntax for-syntax
`(peg-parse-any unknown-el ,lst))))))
;; Parses a literal.
(define (peg-literal->defn lst) (trim-1chars (cadr lst)))
(define (peg-literal->defn lst for-syntax)
(datum->syntax for-syntax (trim-1chars (cadr lst))))
;; Parses a charclass.
(define (peg-charclass->defn lst)
(cons 'or
(map
(define (peg-charclass->defn lst for-syntax)
#`(or
#,@(map
(lambda (cc)
(cond
((eq? (car cc) 'charclass-range)
`(range ,(string-ref (cadr cc) 0) ,(string-ref (cadr cc) 2)))
#`(range #,(datum->syntax
for-syntax
(string-ref (cadr cc) 0))
#,(datum->syntax
for-syntax
(string-ref (cadr cc) 2))))
((eq? (car cc) 'charclass-single)
(cadr cc))))
(datum->syntax for-syntax (cadr cc)))))
(context-flatten
(lambda (x) (or (eq? (car x) 'charclass-range)
(eq? (car x) 'charclass-single)))
@ -404,27 +418,30 @@ RB < ']'
;; Compresses a list to save the optimizer work.
;; e.g. (or (and a)) -> a
(define (compressor lst)
(define (compressor-core lst)
(if (or (not (list? lst)) (null? lst))
lst
(cond
((and (or (eq? (car lst) 'or) (eq? (car lst) 'and))
(null? (cddr lst)))
(compressor (cadr lst)))
(compressor-core (cadr lst)))
((and (eq? (car lst) 'body)
(eq? (cadr lst) 'lit)
(eq? (cadddr lst) 1))
(compressor (caddr lst)))
(else (map compressor lst)))))
(compressor-core (caddr lst)))
(else (map compressor-core lst)))))
(define (compressor syn for-syntax)
(datum->syntax for-syntax
(compressor-core (syntax->datum syn))))
;; Builds a lambda-expressions for the pattern STR using accum.
(define (peg-string-compile str-stx accum)
(peg-sexp-compile
(datum->syntax
str-stx
(compressor
(peg-pattern->defn
(peg:tree (peg-parse peg-pattern (syntax->datum str-stx))))))
(peg:tree (peg-parse peg-pattern (syntax->datum str-stx))) str-stx)
str-stx)
accum))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;