Make Macros Hygienic

 * modules/ice-9/peg.scm: convert the unhygienic macros that generate code
    for string PEGs to use hygiene.

1 files changed, 73 insertions, 56 deletions

diff --git a/module/ice-9/peg.scm b/module/ice-9/peg.scm
index e256c2dc9..9bf152c86 100644
--- a/module/ice-9/peg.scm
+++ b/module/ice-9/peg.scm
@@ -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,9 +305,10 @@ RB < ']'
            ((or (not (list? lst)) (null? lst))
             lst)
            ((eq? (car lst) 'peg-grammar)
-            (cons 'begin (map (lambda (x) (peg-nonterm->defn x))
-                              (context-flatten (lambda (lst) (<= (depth lst) 2))
-                                          (cdr lst))))))))))
+            #`(begin
+                #,@(map (lambda (x) (peg-nonterm->defn x for-syntax))
+                        (context-flatten (lambda (lst) (<= (depth lst) 2))
+                                         (cdr lst))))))))))
 
 ;; Macro wrapper for PEG-PARSER.  Parses PEG grammars expressed as strings and
 ;; defines all the appropriate nonterminals.
@@ -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))
-        (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)))))
+(define (peg-nonterm->defn lst for-syntax)
+  (let* ((nonterm (car lst))
+         (grabber (cadr lst))
+         (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
-                 (context-flatten (lambda (x) (eq? (car x) 'peg-alternative))
-                             (cdr lst)))))
+(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
-                  (context-flatten (lambda (x) (or (string? (car x))
-                                              (eq? (car x) 'peg-suffix)))
-                              (cdr lst)))))
+(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))
-            1
-            (string->symbol (caddr lst)))))
+(define (peg-suffix->defn lst for-syntax)
+  #`(#,(peg-primary->defn (cadr lst) for-syntax)
+     #,(if (null? (cddr lst))
+           1
+           (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))))))
+   (compressor
+    (peg-pattern->defn
+     (peg:tree (peg-parse peg-pattern (syntax->datum str-stx))) str-stx)
+    str-stx)
    accum))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;