* bug#73188: PEG parser does not support full PEG grammar
@ 2024-09-11 22:03 Ekaitz Zarraga
2024-09-12 20:57 ` bug#73188: [PATCH v2] PEG: Add full support for PEG + some extensions Ekaitz Zarraga
2024-10-11 12:31 ` bug#73188: [PATCH] PEG: Add support for `not-in-range` and [^...] Ekaitz Zarraga
0 siblings, 2 replies; 7+ messages in thread
From: Ekaitz Zarraga @ 2024-09-11 22:03 UTC (permalink / raw)
To: 73188
[-- Attachment #1: Type: text/plain, Size: 565 bytes --]
Hi,
I noticed the PEG parser does not support the full PEG grammar, this
includes comments, double quotes, escaping and underscores.
The attached patch adds support for those (I sent it to guile-devel but
I guess it's better to do it here).
I'm trying to test it with Zig's grammar but I'm having some issues and
the way this is generated it's really hard to test. As is, this patch
passes all the current tests in Guile which includes being able to parse
peg-as-peg, which now has comments and features that were not
implemented before.
Thank you,
Ekaitz
[-- Attachment #2: 0001-PEG-Add-full-support-for-PEG-some-extensions.patch --]
[-- Type: text/x-patch, Size: 19155 bytes --]
From 2eef66ffdfc0728a84fa1e8a37b2a748bf464324 Mon Sep 17 00:00:00 2001
From: Ekaitz Zarraga <ekaitz@elenq.tech>
Date: Wed, 11 Sep 2024 21:19:26 +0200
Subject: [PATCH] PEG: Add full support for PEG + some extensions
This commit adds support for PEG as described in:
<https://bford.info/pub/lang/peg.pdf>
It adds support for the missing features (comments, underscores in
identifiers and escaping) while keeping the extensions (dashes in
identifiers, < and <--).
The naming system tries to be as close as possible to the one proposed
in the paper.
* module/ice-9/peg/string-peg.scm: Rewrite PEG parser.
* test-suite/tests/peg.test: Fix import
---
module/ice-9/peg/string-peg.scm | 410 +++++++++++++++++++-------------
test-suite/tests/peg.test | 32 ++-
2 files changed, 263 insertions(+), 179 deletions(-)
diff --git a/module/ice-9/peg/string-peg.scm b/module/ice-9/peg/string-peg.scm
index 45ed14bb1..47202064b 100644
--- a/module/ice-9/peg/string-peg.scm
+++ b/module/ice-9/peg/string-peg.scm
@@ -1,6 +1,6 @@
;;;; string-peg.scm --- representing PEG grammars as strings
;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2023 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -22,6 +22,7 @@
define-peg-string-patterns
peg-grammar)
#:use-module (ice-9 peg using-parsers)
+ #:use-module (srfi srfi-1)
#:use-module (ice-9 peg codegen)
#:use-module (ice-9 peg simplify-tree))
@@ -38,21 +39,55 @@
;; Grammar for PEGs in PEG grammar.
(define peg-as-peg
-"grammar <-- (nonterminal ('<--' / '<-' / '<') sp pattern)+
-pattern <-- alternative (SLASH sp alternative)*
-alternative <-- ([!&]? sp suffix)+
-suffix <-- primary ([*+?] sp)*
-primary <-- '(' sp pattern ')' sp / '.' sp / literal / charclass / nonterminal !'<'
-literal <-- ['] (!['] .)* ['] sp
-charclass <-- LB (!']' (CCrange / CCsingle))* RB sp
-CCrange <-- . '-' .
-CCsingle <-- .
-nonterminal <-- [a-zA-Z0-9-]+ sp
-sp < [ \t\n]*
-SLASH < '/'
-LB < '['
-RB < ']'
-")
+"# Hierarchical syntax
+Grammar <-- Spacing Definition+ EndOfFile
+Definition <-- Identifier LEFTARROW Expression
+
+Expression <-- Sequence (SLASH Sequence)*
+Sequence <-- Prefix*
+Prefix <-- (AND / NOT)? Suffix
+Suffix <-- Primary (QUESTION / STAR / PLUS)?
+Primary <-- Identifier !LEFTARROW
+ / OPEN Expression CLOSE
+ / Literal / Class / DOT
+
+# Lexical syntax
+Identifier <-- IdentStart IdentCont* Spacing
+# NOTE: `-` is an extension
+IdentStart <- [a-zA-Z_-]
+IdentCont <- IdentStart / [0-9]
+
+Literal <-- SQUOTE (!SQUOTE Char)* SQUOTE Spacing
+ / DQUOTE (!DQUOTE Char)* DQUOTE Spacing
+Class <-- '[' (!']' Range)* ']' Spacing
+Range <-- Char '-' Char / Char
+Char <-- '\\\\' [nrt'\"\\[\\]\\\\]
+ / '\\\\' [0-2][0-7][0-7]
+ / '\\\\' [0-7][0-7]?
+ / !'\\\\' .
+
+# NOTE: `<--` and `<` are extensions
+LEFTARROW <- ('<--' / '<-' / '<') Spacing
+SQUOTE <-- [']
+DQUOTE <-- [\"]
+OPENBRACKET < '['
+CLOSEBRACKET < ']'
+SLASH < '/' Spacing
+AND <-- '&' Spacing
+NOT <-- '!' Spacing
+QUESTION <-- '?' Spacing
+STAR <-- '*' Spacing
+PLUS <-- '+' Spacing
+OPEN < '(' Spacing
+CLOSE < ')' Spacing
+DOT <-- '.' Spacing
+
+Spacing < (Space / Comment)*
+Comment < '#' (!EndOfLine .)* EndOfLine
+Space < ' ' / '\t' / EndOfLine
+EndOfLine < '\r\n' / '\n' / '\r'
+EndOfFile < !.")
+
(define-syntax define-sexp-parser
(lambda (x)
@@ -63,35 +98,78 @@ RB < ']'
(syn (wrap-parser-for-users x matchf accumsym #'sym)))
#`(define sym #,syn))))))
-(define-sexp-parser peg-grammar all
- (+ (and peg-nonterminal (or "<--" "<-" "<") peg-sp peg-pattern)))
-(define-sexp-parser peg-pattern all
- (and peg-alternative
- (* (and (ignore "/") peg-sp peg-alternative))))
-(define-sexp-parser peg-alternative all
- (+ (and (? (or "!" "&")) peg-sp peg-suffix)))
-(define-sexp-parser peg-suffix all
- (and peg-primary (* (and (or "*" "+" "?") peg-sp))))
-(define-sexp-parser peg-primary all
- (or (and "(" peg-sp peg-pattern ")" peg-sp)
- (and "." peg-sp)
- peg-literal
- peg-charclass
- (and peg-nonterminal (not-followed-by "<"))))
-(define-sexp-parser peg-literal all
- (and "'" (* (and (not-followed-by "'") peg-any)) "'" peg-sp))
-(define-sexp-parser peg-charclass all
- (and (ignore "[")
- (* (and (not-followed-by "]")
- (or charclass-range charclass-single)))
- (ignore "]")
- peg-sp))
-(define-sexp-parser charclass-range all (and peg-any "-" peg-any))
-(define-sexp-parser charclass-single all peg-any)
-(define-sexp-parser peg-nonterminal all
- (and (+ (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) "-")) peg-sp))
-(define-sexp-parser peg-sp none
- (* (or " " "\t" "\n")))
+(define-sexp-parser Grammar all
+ (and Spacing (+ Definition) EndOfFile))
+(define-sexp-parser Definition all
+ (and Identifier LEFTARROW Expression))
+(define-sexp-parser Expression all
+ (and Sequence (* (and SLASH Sequence))))
+(define-sexp-parser Sequence all
+ (* Prefix))
+(define-sexp-parser Prefix all
+ (and (? (or AND NOT)) Suffix))
+(define-sexp-parser Suffix all
+ (and Primary (? (or QUESTION STAR PLUS))))
+(define-sexp-parser Primary all
+ (or (and Identifier (not-followed-by LEFTARROW))
+ (and OPEN Expression CLOSE)
+ Literal
+ Class
+ DOT))
+(define-sexp-parser Identifier all
+ (and IdentStart (* IdentCont) Spacing))
+(define-sexp-parser IdentStart body
+ (or (range #\a #\z) (range #\A #\Z) "_" "-"))
+(define-sexp-parser IdentCont body
+ (or IdentStart (range #\0 #\9)))
+(define-sexp-parser Literal all
+ (or (and SQUOTE (* (and (not-followed-by SQUOTE) Char)) SQUOTE Spacing)
+ (and DQUOTE (* (and (not-followed-by DQUOTE) Char)) DQUOTE Spacing)))
+(define-sexp-parser Class all
+ (and OPENBRACKET (* (and (not-followed-by CLOSEBRACKET) Range)) CLOSEBRACKET Spacing))
+(define-sexp-parser Range all
+ (or (and Char DASH Char) Char))
+(define-sexp-parser Char all
+ (or (and "\\" (or "n" "r" "t" "'" "[" "]" "\\"))
+ (and "\\" (range #\0 #\2) (range #\0 #\7) (range #\0 #\7))
+ (and "\\" (range #\0 #\7) (? (range #\0 #\7)))
+ (and (not-followed-by "\\") peg-any)))
+(define-sexp-parser LEFTARROW body
+ (and (or "<--" "<-" "<") Spacing)) ; NOTE: <-- and < are extensions
+(define-sexp-parser SLASH none
+ (and "/" Spacing))
+(define-sexp-parser AND all
+ (and "&" Spacing))
+(define-sexp-parser NOT all
+ (and "!" Spacing))
+(define-sexp-parser QUESTION all
+ (and "?" Spacing))
+(define-sexp-parser STAR all
+ (and "*" Spacing))
+(define-sexp-parser PLUS all
+ (and "+" Spacing))
+(define-sexp-parser OPEN none
+ (and "(" Spacing))
+(define-sexp-parser CLOSE none
+ (and ")" Spacing))
+(define-sexp-parser DOT all
+ (and "." Spacing))
+(define-sexp-parser SQUOTE none "'")
+(define-sexp-parser DQUOTE none "\"")
+(define-sexp-parser OPENBRACKET none "[")
+(define-sexp-parser CLOSEBRACKET none "]")
+(define-sexp-parser DASH none "-")
+(define-sexp-parser Spacing none
+ (* (or Space Comment)))
+(define-sexp-parser Comment none
+ (and "#" (* (and (not-followed-by EndOfLine) peg-any)) EndOfLine))
+(define-sexp-parser Space none
+ (or " " "\t" EndOfLine))
+(define-sexp-parser EndOfLine none
+ (or "\r\n" "\n" "\r"))
+(define-sexp-parser EndOfFile none
+ (not-followed-by peg-any))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; PARSE STRING PEGS
@@ -101,7 +179,7 @@ RB < ']'
;; will define all of the nonterminals in the grammar with equivalent
;; PEG s-expressions.
(define (peg-parser str for-syntax)
- (let ((parsed (match-pattern peg-grammar str)))
+ (let ((parsed (match-pattern Grammar str)))
(if (not parsed)
(begin
;; (display "Invalid PEG grammar!\n")
@@ -110,11 +188,123 @@ RB < ']'
(cond
((or (not (list? lst)) (null? lst))
lst)
- ((eq? (car lst) 'peg-grammar)
- #`(begin
- #,@(map (lambda (x) (peg-nonterm->defn x for-syntax))
- (context-flatten (lambda (lst) (<= (depth lst) 2))
- (cdr lst))))))))))
+ ((eq? (car lst) 'Grammar)
+ (Grammar->defn lst for-syntax)))))))
+
+;; (Grammar (Definition ...) (Definition ...))
+(define (Grammar->defn lst for-syntax)
+ #`(begin
+ #,@(map (lambda (x) (Definition->defn x for-syntax))
+ (context-flatten (lambda (lst) (<= (depth lst) 1))
+ (cdr lst)))))
+
+;; (Definition (Identifier "Something") "<-" (Expression ...))
+;; `-> (define-peg-pattern Something 'all ...)
+(define (Definition->defn lst for-syntax)
+ (let ((identifier (second (second lst)))
+ (grabber (third lst))
+ (expression (fourth lst)))
+ #`(define-peg-pattern #,(datum->syntax for-syntax
+ (string->symbol identifier))
+ #,(cond
+ ((string=? grabber "<--") (datum->syntax for-syntax 'all))
+ ((string=? grabber "<-") (datum->syntax for-syntax 'body))
+ (else (datum->syntax for-syntax 'none)))
+ #,(compressor (Expression->defn expression for-syntax) for-syntax))))
+
+;; (Expression (Sequence X))
+;; `-> (X)
+;; (Expression (Sequence X) (Sequence Y))
+;; `-> (or X Y)
+;; (Expression (Sequence X) ((Sequence Y) (Sequence Z) ...))
+;; `-> (or X Y Z ...)
+(define (Expression->defn lst for-syntax)
+ (let ((first-sequence (second lst))
+ (rest (cddr lst)))
+ #`(or #,(Sequence->defn first-sequence for-syntax)
+ #,@(map (lambda (x)
+ (Sequence->defn x for-syntax))
+ (keyword-flatten '(Sequence) rest)))))
+
+
+(define (Sequence->defn lst for-syntax)
+ #`(and #,@(map (lambda (x) (Prefix->defn x for-syntax)) (cdr lst))))
+
+
+;; (Prefix (Suffix ...))
+;; `-> (...)
+;; (Prefix (NOT "!") (Suffix ...))
+;; `-> (not-followed-by ...)
+;; (Prefix (AND "&") (Suffix ...))
+;; `-> (followed-by ...)
+(define (Prefix->defn lst for-syntax)
+ (let ((suffix (second lst)))
+ (case (car suffix)
+ ('AND #`(followed-by #,(Suffix->defn (third lst) for-syntax)))
+ ('NOT #`(not-followed-by #,(Suffix->defn (third lst) for-syntax)))
+ (else (Suffix->defn suffix for-syntax)))))
+
+;; (Suffix (Primary ...))
+;; `-> (...)
+;; (Suffix (Primary ...) (STAR "*"))
+;; `-> (* ...)
+;; (Suffix (Primary ...) (QUESTION "?"))
+;; `-> (? ...)
+;; (Suffix (Primary ...) (PLUS "+"))
+;; `-> (+ ...)
+(define (Suffix->defn lst for-syntax)
+ (let* ((primary (second lst))
+ (out (Primary->defn primary for-syntax))
+ (extra (cddr lst)))
+ (if (null? extra)
+ out
+ (case (caar extra)
+ ('QUESTION #`(? #,out))
+ ('STAR #`(* #,out))
+ ('PLUS #`(+ #,out))))))
+
+(define (Primary->defn lst for-syntax)
+ (let ((value (second lst)))
+ (case (car value)
+ ('DOT #'peg-any)
+ ('Identifier (Identifier->defn value for-syntax))
+ ('Expression (Expression->defn value for-syntax))
+ ('Literal (Literal->defn value for-syntax))
+ ('Class (Class->defn value for-syntax)))))
+
+;; (Identifier "hello")
+;; `-> hello
+(define (Identifier->defn lst for-syntax)
+ (datum->syntax for-syntax (string->symbol (second lst))))
+
+;; (Literal (Char "a") (Char "b") (Char "c"))
+;; `-> "abc"
+(define (Literal->defn lst for-syntax)
+ (apply string-append (map second (cdr lst))))
+
+;; TODO: empty Class can happen: `[]`, but what does it represent?
+;; (Class ...)
+;; `-> (or ...)
+(define (Class->defn lst for-syntax)
+ #`(or #,@(map (lambda (x)
+ (Range->defn x for-syntax))
+ (cdr lst))))
+
+;; For one character:
+;; (Range (Char "a"))
+;; `-> "a"
+;; Or for a range:
+;; (Range (Char "a") (Char "b"))
+;; `-> (range #\a #\b)
+(define (Range->defn lst for-syntax)
+ (cond
+ ((= 2 (length lst))
+ (second (second lst)))
+ ((= 3 (length lst))
+ #`(range #,(string-ref (second (second lst)) 0)
+ #,(string-ref (second (third lst)) 0)))))
+
+(define peg-grammar Grammar)
;; Macro wrapper for PEG-PARSER. Parses PEG grammars expressed as strings and
;; defines all the appropriate nonterminals.
@@ -124,119 +314,6 @@ RB < ']'
((_ str)
(peg-parser (syntax->datum #'str) x)))))
-;; lst has format (nonterm grabber pattern), where
-;; nonterm is a symbol (the name of the nonterminal),
-;; grabber is a string (either "<", "<-" or "<--"), and
-;; pattern is the parse of a PEG pattern expressed as as string.
-(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-peg-pattern #,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))))
-
-;; lst has format ('peg-pattern ...).
-;; After the context-flatten, (cdr lst) has format
-;; (('peg-alternative ...) ...), where the outer list is a collection
-;; of elements from a '/' alternative.
-(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)))))
-
-;; lst has format ('peg-alternative ...).
-;; After the context-flatten, (cdr lst) has the format
-;; (item ...), where each item has format either ("!" ...), ("&" ...),
-;; or ('peg-suffix ...).
-(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)))))
-
-;; lst has the format either
-;; ("!" ('peg-suffix ...)), ("&" ('peg-suffix ...)), or
-;; ('peg-suffix ...).
-(define (peg-body->defn lst for-syntax)
- (cond
- ((equal? (car lst) "&")
- #`(followed-by #,(peg-suffix->defn (cadr lst) for-syntax)))
- ((equal? (car lst) "!")
- #`(not-followed-by #,(peg-suffix->defn (cadr lst) for-syntax)))
- ((eq? (car lst) 'peg-suffix)
- (peg-suffix->defn lst for-syntax))
- (else `(peg-parse-body-fail ,lst))))
-
-;; lst has format ('peg-suffix <peg-primary> (? (/ "*" "?" "+")))
-(define (peg-suffix->defn lst for-syntax)
- (let ((inner-defn (peg-primary->defn (cadr lst) for-syntax)))
- (cond
- ((null? (cddr lst))
- inner-defn)
- ((equal? (caddr lst) "*")
- #`(* #,inner-defn))
- ((equal? (caddr lst) "?")
- #`(? #,inner-defn))
- ((equal? (caddr lst) "+")
- #`(+ #,inner-defn)))))
-
-;; Parse a primary.
-(define (peg-primary->defn lst for-syntax)
- (let ((el (cadr lst)))
- (cond
- ((list? el)
- (cond
- ((eq? (car el) 'peg-literal)
- (peg-literal->defn el for-syntax))
- ((eq? (car el) 'peg-charclass)
- (peg-charclass->defn el for-syntax))
- ((eq? (car el) 'peg-nonterminal)
- (datum->syntax for-syntax (string->symbol (cadr el))))))
- ((string? el)
- (cond
- ((equal? el "(")
- (peg-pattern->defn (caddr lst) for-syntax))
- ((equal? el ".")
- (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))))))
-
-;; Trims characters off the front and end of STR.
-;; (trim-1chars "'ab'") -> "ab"
-(define (trim-1chars str) (substring str 1 (- (string-length str) 1)))
-
-;; Parses a literal.
-(define (peg-literal->defn lst for-syntax)
- (datum->syntax for-syntax (trim-1chars (cadr lst))))
-
-;; Parses a charclass.
-(define (peg-charclass->defn lst for-syntax)
- #`(or
- #,@(map
- (lambda (cc)
- (cond
- ((eq? (car cc) 'charclass-range)
- #`(range #,(datum->syntax
- for-syntax
- (string-ref (cadr cc) 0))
- #,(datum->syntax
- for-syntax
- (string-ref (cadr cc) 2))))
- ((eq? (car cc) 'charclass-single)
- (datum->syntax for-syntax (cadr cc)))))
- (context-flatten
- (lambda (x) (or (eq? (car x) 'charclass-range)
- (eq? (car x) 'charclass-single)))
- (cdr lst)))))
-
;; Compresses a list to save the optimizer work.
;; e.g. (or (and a)) -> a
(define (compressor-core lst)
@@ -263,11 +340,10 @@ RB < ']'
(let ((string (syntax->datum #'str-stx)))
(compile-peg-pattern
(compressor
- (peg-pattern->defn
- (peg:tree (match-pattern peg-pattern string)) #'str-stx)
+ (Expression->defn
+ (peg:tree (match-pattern Expression string)) #'str-stx)
#'str-stx)
(if (eq? accum 'all) 'body accum))))
(else (error "Bad embedded PEG string" args))))
(add-peg-compiler! 'peg peg-string-compile)
-
diff --git a/test-suite/tests/peg.test b/test-suite/tests/peg.test
index f516571e8..556145e72 100644
--- a/test-suite/tests/peg.test
+++ b/test-suite/tests/peg.test
@@ -28,17 +28,25 @@
;; the nonterminals defined in the PEG parser written with
;; S-expressions.
(define grammar-mapping
- '((grammar peg-grammar)
- (pattern peg-pattern)
- (alternative peg-alternative)
- (suffix peg-suffix)
- (primary peg-primary)
- (literal peg-literal)
- (charclass peg-charclass)
- (CCrange charclass-range)
- (CCsingle charclass-single)
- (nonterminal peg-nonterminal)
- (sp peg-sp)))
+ '((Grammar Grammar)
+ (Definition Definition)
+ (Expression Expression)
+ (Sequence Sequence)
+ (Prefix Prefix)
+ (Suffix Suffix)
+ (Primary Primary)
+ (Identifier Identifier)
+ (Literal Literal)
+ (Class Class)
+ (Range Range)
+ (Char Char)
+ (LEFTARROW LEFTARROW)
+ (AND AND)
+ (NOT NOT)
+ (QUESTION QUESTION)
+ (STAR STAR)
+ (PLUS PLUS)
+ (DOT DOT)))
;; Transforms the nonterminals defined in the PEG parser written as a PEG to the nonterminals defined in the PEG parser written with S-expressions.
(define (grammar-transform x)
@@ -69,7 +77,7 @@
(peg:tree (match-pattern (@@ (ice-9 peg) peg-grammar) (@@ (ice-9 peg) peg-as-peg)))
(tree-map
grammar-transform
- (peg:tree (match-pattern grammar (@@ (ice-9 peg) peg-as-peg)))))))
+ (peg:tree (match-pattern (@@ (ice-9 peg) peg-grammar) (@@ (ice-9 peg) peg-as-peg)))))))
;; A grammar for pascal-style comments from Wikipedia.
(define comment-grammar
--
2.45.2
^ permalink raw reply related [flat|nested] 7+ messages in thread
* bug#73188: [PATCH v2] PEG: Add full support for PEG + some extensions
2024-09-11 22:03 bug#73188: PEG parser does not support full PEG grammar Ekaitz Zarraga
@ 2024-09-12 20:57 ` Ekaitz Zarraga
2024-10-13 20:29 ` bug#73188: PEG parser does not support full PEG grammar Ludovic Courtès
2024-10-11 12:31 ` bug#73188: [PATCH] PEG: Add support for `not-in-range` and [^...] Ekaitz Zarraga
1 sibling, 1 reply; 7+ messages in thread
From: Ekaitz Zarraga @ 2024-09-12 20:57 UTC (permalink / raw)
To: 73188; +Cc: Ekaitz Zarraga
This commit adds support for PEG as described in:
<https://bford.info/pub/lang/peg.pdf>
It adds support for the missing features (comments, underscores in
identifiers and escaping) while keeping the extensions (dashes in
identifiers, < and <--).
The naming system tries to be as close as possible to the one proposed
in the paper.
* module/ice-9/peg/string-peg.scm: Rewrite PEG parser.
* test-suite/tests/peg.test: Fix import
---
Previus version did not make proper character and escaping control.
module/ice-9/peg/string-peg.scm | 438 ++++++++++++++++++++------------
test-suite/tests/peg.test | 32 ++-
2 files changed, 292 insertions(+), 178 deletions(-)
diff --git a/module/ice-9/peg/string-peg.scm b/module/ice-9/peg/string-peg.scm
index 45ed14bb1..05755693a 100644
--- a/module/ice-9/peg/string-peg.scm
+++ b/module/ice-9/peg/string-peg.scm
@@ -1,6 +1,6 @@
;;;; string-peg.scm --- representing PEG grammars as strings
;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2023 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -22,6 +22,7 @@
define-peg-string-patterns
peg-grammar)
#:use-module (ice-9 peg using-parsers)
+ #:use-module (srfi srfi-1)
#:use-module (ice-9 peg codegen)
#:use-module (ice-9 peg simplify-tree))
@@ -38,22 +39,57 @@
;; Grammar for PEGs in PEG grammar.
(define peg-as-peg
-"grammar <-- (nonterminal ('<--' / '<-' / '<') sp pattern)+
-pattern <-- alternative (SLASH sp alternative)*
-alternative <-- ([!&]? sp suffix)+
-suffix <-- primary ([*+?] sp)*
-primary <-- '(' sp pattern ')' sp / '.' sp / literal / charclass / nonterminal !'<'
-literal <-- ['] (!['] .)* ['] sp
-charclass <-- LB (!']' (CCrange / CCsingle))* RB sp
-CCrange <-- . '-' .
-CCsingle <-- .
-nonterminal <-- [a-zA-Z0-9-]+ sp
-sp < [ \t\n]*
-SLASH < '/'
-LB < '['
-RB < ']'
+"# Hierarchical syntax
+Grammar <-- Spacing Definition+ EndOfFile
+Definition <-- Identifier LEFTARROW Expression
+
+Expression <-- Sequence (SLASH Sequence)*
+Sequence <-- Prefix*
+Prefix <-- (AND / NOT)? Suffix
+Suffix <-- Primary (QUESTION / STAR / PLUS)?
+Primary <-- Identifier !LEFTARROW
+ / OPEN Expression CLOSE
+ / Literal / Class / DOT
+
+# Lexical syntax
+Identifier <-- IdentStart IdentCont* Spacing
+# NOTE: `-` is an extension
+IdentStart <- [a-zA-Z_] / '-'
+IdentCont <- IdentStart / [0-9]
+
+Literal <-- SQUOTE (!SQUOTE Char)* SQUOTE Spacing
+ / DQUOTE (!DQUOTE Char)* DQUOTE Spacing
+Class <-- '[' (!']' Range)* ']' Spacing
+Range <-- Char '-' Char / Char
+Char <-- '\\\\' [nrt'\"\\[\\]\\\\]
+ / '\\\\' [0-7][0-7][0-7]
+ / '\\\\' [0-7][0-7]?
+ / !'\\\\' .
+
+# NOTE: `<--` and `<` are extensions
+LEFTARROW <- ('<--' / '<-' / '<') Spacing
+SQUOTE <-- [']
+DQUOTE <-- [\"]
+OPENBRACKET < '['
+CLOSEBRACKET < ']'
+SLASH < '/' Spacing
+AND <-- '&' Spacing
+NOT <-- '!' Spacing
+QUESTION <-- '?' Spacing
+STAR <-- '*' Spacing
+PLUS <-- '+' Spacing
+OPEN < '(' Spacing
+CLOSE < ')' Spacing
+DOT <-- '.' Spacing
+
+Spacing < (Space / Comment)*
+Comment < '#' (!EndOfLine .)* EndOfLine
+Space < ' ' / '\t' / EndOfLine
+EndOfLine < '\\r\\n' / '\\n' / '\\r'
+EndOfFile < !.
")
+
(define-syntax define-sexp-parser
(lambda (x)
(syntax-case x ()
@@ -63,35 +99,78 @@ RB < ']'
(syn (wrap-parser-for-users x matchf accumsym #'sym)))
#`(define sym #,syn))))))
-(define-sexp-parser peg-grammar all
- (+ (and peg-nonterminal (or "<--" "<-" "<") peg-sp peg-pattern)))
-(define-sexp-parser peg-pattern all
- (and peg-alternative
- (* (and (ignore "/") peg-sp peg-alternative))))
-(define-sexp-parser peg-alternative all
- (+ (and (? (or "!" "&")) peg-sp peg-suffix)))
-(define-sexp-parser peg-suffix all
- (and peg-primary (* (and (or "*" "+" "?") peg-sp))))
-(define-sexp-parser peg-primary all
- (or (and "(" peg-sp peg-pattern ")" peg-sp)
- (and "." peg-sp)
- peg-literal
- peg-charclass
- (and peg-nonterminal (not-followed-by "<"))))
-(define-sexp-parser peg-literal all
- (and "'" (* (and (not-followed-by "'") peg-any)) "'" peg-sp))
-(define-sexp-parser peg-charclass all
- (and (ignore "[")
- (* (and (not-followed-by "]")
- (or charclass-range charclass-single)))
- (ignore "]")
- peg-sp))
-(define-sexp-parser charclass-range all (and peg-any "-" peg-any))
-(define-sexp-parser charclass-single all peg-any)
-(define-sexp-parser peg-nonterminal all
- (and (+ (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) "-")) peg-sp))
-(define-sexp-parser peg-sp none
- (* (or " " "\t" "\n")))
+(define-sexp-parser Grammar all
+ (and Spacing (+ Definition) EndOfFile))
+(define-sexp-parser Definition all
+ (and Identifier LEFTARROW Expression))
+(define-sexp-parser Expression all
+ (and Sequence (* (and SLASH Sequence))))
+(define-sexp-parser Sequence all
+ (* Prefix))
+(define-sexp-parser Prefix all
+ (and (? (or AND NOT)) Suffix))
+(define-sexp-parser Suffix all
+ (and Primary (? (or QUESTION STAR PLUS))))
+(define-sexp-parser Primary all
+ (or (and Identifier (not-followed-by LEFTARROW))
+ (and OPEN Expression CLOSE)
+ Literal
+ Class
+ DOT))
+(define-sexp-parser Identifier all
+ (and IdentStart (* IdentCont) Spacing))
+(define-sexp-parser IdentStart body
+ (or (range #\a #\z) (range #\A #\Z) "_" "-")) ; NOTE: - is an extension
+(define-sexp-parser IdentCont body
+ (or IdentStart (range #\0 #\9)))
+(define-sexp-parser Literal all
+ (or (and SQUOTE (* (and (not-followed-by SQUOTE) Char)) SQUOTE Spacing)
+ (and DQUOTE (* (and (not-followed-by DQUOTE) Char)) DQUOTE Spacing)))
+(define-sexp-parser Class all
+ (and OPENBRACKET (* (and (not-followed-by CLOSEBRACKET) Range)) CLOSEBRACKET Spacing))
+(define-sexp-parser Range all
+ (or (and Char DASH Char) Char))
+(define-sexp-parser Char all
+ (or (and "\\" (or "n" "r" "t" "'" "[" "]" "\\"))
+ (and "\\" (range #\0 #\7) (range #\0 #\7) (range #\0 #\7))
+ (and "\\" (range #\0 #\7) (? (range #\0 #\7)))
+ (and (not-followed-by "\\") peg-any)))
+(define-sexp-parser LEFTARROW body
+ (and (or "<--" "<-" "<") Spacing)) ; NOTE: <-- and < are extensions
+(define-sexp-parser SLASH none
+ (and "/" Spacing))
+(define-sexp-parser AND all
+ (and "&" Spacing))
+(define-sexp-parser NOT all
+ (and "!" Spacing))
+(define-sexp-parser QUESTION all
+ (and "?" Spacing))
+(define-sexp-parser STAR all
+ (and "*" Spacing))
+(define-sexp-parser PLUS all
+ (and "+" Spacing))
+(define-sexp-parser OPEN none
+ (and "(" Spacing))
+(define-sexp-parser CLOSE none
+ (and ")" Spacing))
+(define-sexp-parser DOT all
+ (and "." Spacing))
+(define-sexp-parser SQUOTE none "'")
+(define-sexp-parser DQUOTE none "\"")
+(define-sexp-parser OPENBRACKET none "[")
+(define-sexp-parser CLOSEBRACKET none "]")
+(define-sexp-parser DASH none "-")
+(define-sexp-parser Spacing none
+ (* (or Space Comment)))
+(define-sexp-parser Comment none
+ (and "#" (* (and (not-followed-by EndOfLine) peg-any)) EndOfLine))
+(define-sexp-parser Space none
+ (or " " "\t" EndOfLine))
+(define-sexp-parser EndOfLine none
+ (or "\r\n" "\n" "\r"))
+(define-sexp-parser EndOfFile none
+ (not-followed-by peg-any))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; PARSE STRING PEGS
@@ -101,7 +180,7 @@ RB < ']'
;; will define all of the nonterminals in the grammar with equivalent
;; PEG s-expressions.
(define (peg-parser str for-syntax)
- (let ((parsed (match-pattern peg-grammar str)))
+ (let ((parsed (match-pattern Grammar str)))
(if (not parsed)
(begin
;; (display "Invalid PEG grammar!\n")
@@ -110,132 +189,160 @@ RB < ']'
(cond
((or (not (list? lst)) (null? lst))
lst)
- ((eq? (car lst) 'peg-grammar)
- #`(begin
- #,@(map (lambda (x) (peg-nonterm->defn x for-syntax))
- (context-flatten (lambda (lst) (<= (depth lst) 2))
- (cdr lst))))))))))
+ ((eq? (car lst) 'Grammar)
+ (Grammar->defn lst for-syntax)))))))
-;; Macro wrapper for PEG-PARSER. Parses PEG grammars expressed as strings and
-;; defines all the appropriate nonterminals.
-(define-syntax define-peg-string-patterns
- (lambda (x)
- (syntax-case x ()
- ((_ str)
- (peg-parser (syntax->datum #'str) x)))))
+;; (Grammar (Definition ...) (Definition ...))
+(define (Grammar->defn lst for-syntax)
+ #`(begin
+ #,@(map (lambda (x) (Definition->defn x for-syntax))
+ (context-flatten (lambda (lst) (<= (depth lst) 1))
+ (cdr lst)))))
-;; lst has format (nonterm grabber pattern), where
-;; nonterm is a symbol (the name of the nonterminal),
-;; grabber is a string (either "<", "<-" or "<--"), and
-;; pattern is the parse of a PEG pattern expressed as as string.
-(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-peg-pattern #,nonterm-name
+;; (Definition (Identifier "Something") "<-" (Expression ...))
+;; `-> (define-peg-pattern Something 'all ...)
+(define (Definition->defn lst for-syntax)
+ (let ((identifier (second (second lst)))
+ (grabber (third lst))
+ (expression (fourth lst)))
+ #`(define-peg-pattern #,(datum->syntax for-syntax
+ (string->symbol identifier))
#,(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))))
-
-;; lst has format ('peg-pattern ...).
-;; After the context-flatten, (cdr lst) has format
-;; (('peg-alternative ...) ...), where the outer list is a collection
-;; of elements from a '/' alternative.
-(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)))))
-
-;; lst has format ('peg-alternative ...).
-;; After the context-flatten, (cdr lst) has the format
-;; (item ...), where each item has format either ("!" ...), ("&" ...),
-;; or ('peg-suffix ...).
-(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)))))
-
-;; lst has the format either
-;; ("!" ('peg-suffix ...)), ("&" ('peg-suffix ...)), or
-;; ('peg-suffix ...).
-(define (peg-body->defn lst for-syntax)
- (cond
- ((equal? (car lst) "&")
- #`(followed-by #,(peg-suffix->defn (cadr lst) for-syntax)))
- ((equal? (car lst) "!")
- #`(not-followed-by #,(peg-suffix->defn (cadr lst) for-syntax)))
- ((eq? (car lst) 'peg-suffix)
- (peg-suffix->defn lst for-syntax))
- (else `(peg-parse-body-fail ,lst))))
-
-;; lst has format ('peg-suffix <peg-primary> (? (/ "*" "?" "+")))
-(define (peg-suffix->defn lst for-syntax)
- (let ((inner-defn (peg-primary->defn (cadr lst) for-syntax)))
- (cond
- ((null? (cddr lst))
- inner-defn)
- ((equal? (caddr lst) "*")
- #`(* #,inner-defn))
- ((equal? (caddr lst) "?")
- #`(? #,inner-defn))
- ((equal? (caddr lst) "+")
- #`(+ #,inner-defn)))))
-
-;; Parse a primary.
-(define (peg-primary->defn lst for-syntax)
- (let ((el (cadr lst)))
+ #,(compressor (Expression->defn expression for-syntax) for-syntax))))
+
+;; (Expression (Sequence X))
+;; `-> (X)
+;; (Expression (Sequence X) (Sequence Y))
+;; `-> (or X Y)
+;; (Expression (Sequence X) ((Sequence Y) (Sequence Z) ...))
+;; `-> (or X Y Z ...)
+(define (Expression->defn lst for-syntax)
+ (let ((first-sequence (second lst))
+ (rest (cddr lst)))
+ #`(or #,(Sequence->defn first-sequence for-syntax)
+ #,@(map (lambda (x)
+ (Sequence->defn x for-syntax))
+ (keyword-flatten '(Sequence) rest)))))
+
+
+(define (Sequence->defn lst for-syntax)
+ #`(and #,@(map (lambda (x) (Prefix->defn x for-syntax)) (cdr lst))))
+
+
+;; (Prefix (Suffix ...))
+;; `-> (...)
+;; (Prefix (NOT "!") (Suffix ...))
+;; `-> (not-followed-by ...)
+;; (Prefix (AND "&") (Suffix ...))
+;; `-> (followed-by ...)
+(define (Prefix->defn lst for-syntax)
+ (let ((suffix (second lst)))
+ (case (car suffix)
+ ('AND #`(followed-by #,(Suffix->defn (third lst) for-syntax)))
+ ('NOT #`(not-followed-by #,(Suffix->defn (third lst) for-syntax)))
+ (else (Suffix->defn suffix for-syntax)))))
+
+;; (Suffix (Primary ...))
+;; `-> (...)
+;; (Suffix (Primary ...) (STAR "*"))
+;; `-> (* ...)
+;; (Suffix (Primary ...) (QUESTION "?"))
+;; `-> (? ...)
+;; (Suffix (Primary ...) (PLUS "+"))
+;; `-> (+ ...)
+(define (Suffix->defn lst for-syntax)
+ (let* ((primary (second lst))
+ (out (Primary->defn primary for-syntax))
+ (extra (cddr lst)))
+ (if (null? extra)
+ out
+ (case (caar extra)
+ ('QUESTION #`(? #,out))
+ ('STAR #`(* #,out))
+ ('PLUS #`(+ #,out))))))
+
+(define (Primary->defn lst for-syntax)
+ (let ((value (second lst)))
+ (case (car value)
+ ('DOT #'peg-any)
+ ('Identifier (Identifier->defn value for-syntax))
+ ('Expression (Expression->defn value for-syntax))
+ ('Literal (Literal->defn value for-syntax))
+ ('Class (Class->defn value for-syntax)))))
+
+;; (Identifier "hello")
+;; `-> hello
+(define (Identifier->defn lst for-syntax)
+ (datum->syntax for-syntax (string->symbol (second lst))))
+
+;; (Literal (Char "a") (Char "b") (Char "c"))
+;; `-> "abc"
+(define (Literal->defn lst for-syntax)
+ (apply string (map (lambda (x) (Char->defn x for-syntax)) (cdr lst))))
+
+;; TODO: empty Class can happen: `[]`, but what does it represent?
+;; (Class ...)
+;; `-> (or ...)
+(define (Class->defn lst for-syntax)
+ #`(or #,@(map (lambda (x) (Range->defn x for-syntax))
+ (cdr lst))))
+
+;; For one character:
+;; (Range (Char "a"))
+;; `-> "a"
+;; Or for a range:
+;; (Range (Char "a") (Char "b"))
+;; `-> (range #\a #\b)
+(define (Range->defn lst for-syntax)
(cond
- ((list? el)
- (cond
- ((eq? (car el) 'peg-literal)
- (peg-literal->defn el for-syntax))
- ((eq? (car el) 'peg-charclass)
- (peg-charclass->defn el for-syntax))
- ((eq? (car el) 'peg-nonterminal)
- (datum->syntax for-syntax (string->symbol (cadr el))))))
- ((string? el)
+ ((= 2 (length lst))
+ (second (second lst)))
+ ((= 3 (length lst))
+ #`(range
+ #,(Char->defn (second lst) for-syntax)
+ #,(Char->defn (third lst) for-syntax)))))
+
+;; (Char "a")
+;; `-> #\a
+;; (Char "\\n")
+;; `-> #\newline
+;; (Char "\\135")
+;; `-> #\]
+(define (Char->defn lst for-syntax)
+ (let* ((charstr (second lst))
+ (first (string-ref charstr 0)))
(cond
- ((equal? el "(")
- (peg-pattern->defn (caddr lst) for-syntax))
- ((equal? el ".")
- (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))))))
-
-;; Trims characters off the front and end of STR.
-;; (trim-1chars "'ab'") -> "ab"
-(define (trim-1chars str) (substring str 1 (- (string-length str) 1)))
-
-;; Parses a literal.
-(define (peg-literal->defn lst for-syntax)
- (datum->syntax for-syntax (trim-1chars (cadr lst))))
-
-;; Parses a charclass.
-(define (peg-charclass->defn lst for-syntax)
- #`(or
- #,@(map
- (lambda (cc)
- (cond
- ((eq? (car cc) 'charclass-range)
- #`(range #,(datum->syntax
- for-syntax
- (string-ref (cadr cc) 0))
- #,(datum->syntax
- for-syntax
- (string-ref (cadr cc) 2))))
- ((eq? (car cc) 'charclass-single)
- (datum->syntax for-syntax (cadr cc)))))
- (context-flatten
- (lambda (x) (or (eq? (car x) 'charclass-range)
- (eq? (car x) 'charclass-single)))
- (cdr lst)))))
+ ((= 1 (string-length charstr)) first)
+ ((char-numeric? (string-ref charstr 1))
+ (integer->char
+ (reduce + 0
+ (map
+ (lambda (x y)
+ (* (- (char->integer x) (char->integer #\0)) y))
+ (reverse (string->list charstr 1))
+ '(1 8 64)))))
+ (else
+ (case (string-ref charstr 1)
+ ((#\n) #\newline)
+ ((#\r) #\return)
+ ((#\t) #\tab)
+ ((#\') #\')
+ ((#\]) #\])
+ ((#\\) #\\)
+ ((#\[) #\[))))))
+
+(define peg-grammar Grammar)
+
+;; Macro wrapper for PEG-PARSER. Parses PEG grammars expressed as strings and
+;; defines all the appropriate nonterminals.
+(define-syntax define-peg-string-patterns
+ (lambda (x)
+ (syntax-case x ()
+ ((_ str)
+ (peg-parser (syntax->datum #'str) x)))))
;; Compresses a list to save the optimizer work.
;; e.g. (or (and a)) -> a
@@ -263,11 +370,10 @@ RB < ']'
(let ((string (syntax->datum #'str-stx)))
(compile-peg-pattern
(compressor
- (peg-pattern->defn
- (peg:tree (match-pattern peg-pattern string)) #'str-stx)
+ (Expression->defn
+ (peg:tree (match-pattern Expression string)) #'str-stx)
#'str-stx)
(if (eq? accum 'all) 'body accum))))
(else (error "Bad embedded PEG string" args))))
(add-peg-compiler! 'peg peg-string-compile)
-
diff --git a/test-suite/tests/peg.test b/test-suite/tests/peg.test
index f516571e8..556145e72 100644
--- a/test-suite/tests/peg.test
+++ b/test-suite/tests/peg.test
@@ -28,17 +28,25 @@
;; the nonterminals defined in the PEG parser written with
;; S-expressions.
(define grammar-mapping
- '((grammar peg-grammar)
- (pattern peg-pattern)
- (alternative peg-alternative)
- (suffix peg-suffix)
- (primary peg-primary)
- (literal peg-literal)
- (charclass peg-charclass)
- (CCrange charclass-range)
- (CCsingle charclass-single)
- (nonterminal peg-nonterminal)
- (sp peg-sp)))
+ '((Grammar Grammar)
+ (Definition Definition)
+ (Expression Expression)
+ (Sequence Sequence)
+ (Prefix Prefix)
+ (Suffix Suffix)
+ (Primary Primary)
+ (Identifier Identifier)
+ (Literal Literal)
+ (Class Class)
+ (Range Range)
+ (Char Char)
+ (LEFTARROW LEFTARROW)
+ (AND AND)
+ (NOT NOT)
+ (QUESTION QUESTION)
+ (STAR STAR)
+ (PLUS PLUS)
+ (DOT DOT)))
;; Transforms the nonterminals defined in the PEG parser written as a PEG to the nonterminals defined in the PEG parser written with S-expressions.
(define (grammar-transform x)
@@ -69,7 +77,7 @@
(peg:tree (match-pattern (@@ (ice-9 peg) peg-grammar) (@@ (ice-9 peg) peg-as-peg)))
(tree-map
grammar-transform
- (peg:tree (match-pattern grammar (@@ (ice-9 peg) peg-as-peg)))))))
+ (peg:tree (match-pattern (@@ (ice-9 peg) peg-grammar) (@@ (ice-9 peg) peg-as-peg)))))))
;; A grammar for pascal-style comments from Wikipedia.
(define comment-grammar
--
2.45.2
^ permalink raw reply related [flat|nested] 7+ messages in thread
* bug#73188: [PATCH] PEG: Add support for `not-in-range` and [^...]
2024-09-11 22:03 bug#73188: PEG parser does not support full PEG grammar Ekaitz Zarraga
2024-09-12 20:57 ` bug#73188: [PATCH v2] PEG: Add full support for PEG + some extensions Ekaitz Zarraga
@ 2024-10-11 12:31 ` Ekaitz Zarraga
1 sibling, 0 replies; 7+ messages in thread
From: Ekaitz Zarraga @ 2024-10-11 12:31 UTC (permalink / raw)
To: 73188; +Cc: Ekaitz Zarraga
Modern PEG supports inversed class like `[^a-z]` that would get any
character not in the `a-z` range. This commit adds support for that and
also for a new `not-in-range` PEG pattern for scheme.
* module/ice-9/peg/codegen.scm (cg-not-in-range): New function.
* module/ice-9/peg/string-peg.scm: Add support for `[^...]`
* test-suite/tests/peg.test: Test it.
* doc/ref/api-peg.texi: Document accordingly.
---
doc/ref/api-peg.texi | 8 +++++++
module/ice-9/peg/codegen.scm | 22 +++++++++++++++++++
module/ice-9/peg/string-peg.scm | 39 +++++++++++++++++++++++++++++----
test-suite/tests/peg.test | 6 ++++-
4 files changed, 70 insertions(+), 5 deletions(-)
diff --git a/doc/ref/api-peg.texi b/doc/ref/api-peg.texi
index d34ddc64c..f2707442c 100644
--- a/doc/ref/api-peg.texi
+++ b/doc/ref/api-peg.texi
@@ -143,6 +143,14 @@ Parses any character falling between @var{a} and @var{z}.
@code{(range #\a #\z)}
@end deftp
+@deftp {PEG Pattern} {inversed range of characters} a z
+Parses any character not falling between @var{a} and @var{z}.
+
+@code{"[^a-z]"}
+
+@code{(not-in-range #\a #\z)}
+@end deftp
+
Example:
@example
diff --git a/module/ice-9/peg/codegen.scm b/module/ice-9/peg/codegen.scm
index d80c3e849..82367ef55 100644
--- a/module/ice-9/peg/codegen.scm
+++ b/module/ice-9/peg/codegen.scm
@@ -140,6 +140,27 @@ return EXP."
((none) #`(list (1+ pos) '()))
(else (error "bad accum" accum))))))))))
+;; Generates code for matching a range of characters not between start and end.
+;; E.g.: (cg-not-in-range syntax #\a #\z 'body)
+(define (cg-not-in-range pat accum)
+ (syntax-case pat ()
+ ((start end)
+ (if (not (and (char? (syntax->datum #'start))
+ (char? (syntax->datum #'end))))
+ (error "range PEG should have characters after it; instead got"
+ #'start #'end))
+ #`(lambda (str len pos)
+ (and (< pos len)
+ (let ((c (string-ref str pos)))
+ (and (or (char<? c start) (char>? c end))
+ #,(case accum
+ ((all) #`(list (1+ pos)
+ (list 'cg-not-in-range (string c))))
+ ((name) #`(list (1+ pos) 'cg-not-in-range))
+ ((body) #`(list (1+ pos) (string c)))
+ ((none) #`(list (1+ pos) '()))
+ (else (error "bad accum" accum))))))))))
+
;; Generate code to match a pattern and do nothing with the result
(define (cg-ignore pat accum)
(syntax-case pat ()
@@ -304,6 +325,7 @@ return EXP."
(assq-set! peg-compiler-alist symbol function)))
(add-peg-compiler! 'range cg-range)
+(add-peg-compiler! 'not-in-range cg-not-in-range)
(add-peg-compiler! 'ignore cg-ignore)
(add-peg-compiler! 'capture cg-capture)
(add-peg-compiler! 'and cg-and)
diff --git a/module/ice-9/peg/string-peg.scm b/module/ice-9/peg/string-peg.scm
index 05755693a..f88d2f7d8 100644
--- a/module/ice-9/peg/string-peg.scm
+++ b/module/ice-9/peg/string-peg.scm
@@ -49,7 +49,7 @@ Prefix <-- (AND / NOT)? Suffix
Suffix <-- Primary (QUESTION / STAR / PLUS)?
Primary <-- Identifier !LEFTARROW
/ OPEN Expression CLOSE
- / Literal / Class / DOT
+ / Literal / Class / NotInClass / DOT
# Lexical syntax
Identifier <-- IdentStart IdentCont* Spacing
@@ -59,7 +59,8 @@ IdentCont <- IdentStart / [0-9]
Literal <-- SQUOTE (!SQUOTE Char)* SQUOTE Spacing
/ DQUOTE (!DQUOTE Char)* DQUOTE Spacing
-Class <-- '[' (!']' Range)* ']' Spacing
+NotInClass <-- '[' NOTIN (!']' Range)* ']' Spacing
+Class <-- '[' !NOTIN (!']' Range)* ']' Spacing
Range <-- Char '-' Char / Char
Char <-- '\\\\' [nrt'\"\\[\\]\\\\]
/ '\\\\' [0-7][0-7][0-7]
@@ -72,6 +73,7 @@ SQUOTE <-- [']
DQUOTE <-- [\"]
OPENBRACKET < '['
CLOSEBRACKET < ']'
+NOTIN < '^'
SLASH < '/' Spacing
AND <-- '&' Spacing
NOT <-- '!' Spacing
@@ -116,6 +118,7 @@ EndOfFile < !.
(and OPEN Expression CLOSE)
Literal
Class
+ NotInClass
DOT))
(define-sexp-parser Identifier all
(and IdentStart (* IdentCont) Spacing))
@@ -127,7 +130,11 @@ EndOfFile < !.
(or (and SQUOTE (* (and (not-followed-by SQUOTE) Char)) SQUOTE Spacing)
(and DQUOTE (* (and (not-followed-by DQUOTE) Char)) DQUOTE Spacing)))
(define-sexp-parser Class all
- (and OPENBRACKET (* (and (not-followed-by CLOSEBRACKET) Range)) CLOSEBRACKET Spacing))
+ (and OPENBRACKET (not-followed-by NOTIN)
+ (* (and (not-followed-by CLOSEBRACKET) Range)) CLOSEBRACKET Spacing))
+(define-sexp-parser NotInClass all
+ (and OPENBRACKET NOTIN
+ (* (and (not-followed-by CLOSEBRACKET) Range)) CLOSEBRACKET Spacing))
(define-sexp-parser Range all
(or (and Char DASH Char) Char))
(define-sexp-parser Char all
@@ -137,6 +144,8 @@ EndOfFile < !.
(and (not-followed-by "\\") peg-any)))
(define-sexp-parser LEFTARROW body
(and (or "<--" "<-" "<") Spacing)) ; NOTE: <-- and < are extensions
+(define-sexp-parser NOTIN none
+ (and "^"))
(define-sexp-parser SLASH none
(and "/" Spacing))
(define-sexp-parser AND all
@@ -271,6 +280,7 @@ EndOfFile < !.
('Identifier (Identifier->defn value for-syntax))
('Expression (Expression->defn value for-syntax))
('Literal (Literal->defn value for-syntax))
+ ('NotInClass (NotInClass->defn value for-syntax))
('Class (Class->defn value for-syntax)))))
;; (Identifier "hello")
@@ -283,13 +293,34 @@ EndOfFile < !.
(define (Literal->defn lst for-syntax)
(apply string (map (lambda (x) (Char->defn x for-syntax)) (cdr lst))))
-;; TODO: empty Class can happen: `[]`, but what does it represent?
+;; (NotInClass ...)
+;; `-> (and ...)
+(define (NotInClass->defn lst for-syntax)
+ #`(and #,@(map (lambda (x) (NotInRange->defn x for-syntax))
+ (cdr lst))))
+
;; (Class ...)
;; `-> (or ...)
(define (Class->defn lst for-syntax)
#`(or #,@(map (lambda (x) (Range->defn x for-syntax))
(cdr lst))))
+;; For one character:
+;; (NotInRange (Char "a"))
+;; `-> (not-in-range #\a #\a)
+;; Or for a range:
+;; (NotInRange (Char "a") (Char "b"))
+;; `-> (not-in-range #\a #\b)
+(define (NotInRange->defn lst for-syntax)
+ (cond
+ ((= 2 (length lst))
+ (let ((ch (Char->defn (second lst) for-syntax)))
+ #`(not-in-range #,ch #,ch)))
+ ((= 3 (length lst))
+ #`(not-in-range
+ #,(Char->defn (second lst) for-syntax)
+ #,(Char->defn (third lst) for-syntax)))))
+
;; For one character:
;; (Range (Char "a"))
;; `-> "a"
diff --git a/test-suite/tests/peg.test b/test-suite/tests/peg.test
index 556145e72..965e1c12f 100644
--- a/test-suite/tests/peg.test
+++ b/test-suite/tests/peg.test
@@ -38,6 +38,7 @@
(Identifier Identifier)
(Literal Literal)
(Class Class)
+ (NotInClass NotInClass)
(Range Range)
(Char Char)
(LEFTARROW LEFTARROW)
@@ -85,7 +86,7 @@
End <-- '*)'
C <- Begin N* End
N <- C / (!Begin !End Z)
-Z <- .")
+Z <- [^X-Z]") ;; Forbid some characters to test not-in-range
;; A short /etc/passwd file.
(define *etc-passwd*
@@ -125,6 +126,9 @@ SLASH < '/'")
(match-pattern C "(*blah*)")
(make-prec 0 8 "(*blah*)"
'((Begin "(*") "blah" (End "*)")))))
+ (pass-if
+ "simple comment with forbidden char"
+ (not (match-pattern C "(*blYh*)")))
(pass-if
"simple comment padded"
(equal?
--
2.46.0
^ permalink raw reply related [flat|nested] 7+ messages in thread
* bug#73188: PEG parser does not support full PEG grammar
2024-09-12 20:57 ` bug#73188: [PATCH v2] PEG: Add full support for PEG + some extensions Ekaitz Zarraga
@ 2024-10-13 20:29 ` Ludovic Courtès
2024-10-13 20:59 ` Ekaitz Zarraga
0 siblings, 1 reply; 7+ messages in thread
From: Ludovic Courtès @ 2024-10-13 20:29 UTC (permalink / raw)
To: Ekaitz Zarraga; +Cc: 73188
Hi Ekaitz,
Ekaitz Zarraga <ekaitz@elenq.tech> skribis:
> This commit adds support for PEG as described in:
>
> <https://bford.info/pub/lang/peg.pdf>
I would make this a comment below the ‘define-module’ form.
> It adds support for the missing features (comments, underscores in
> identifiers and escaping) while keeping the extensions (dashes in
> identifiers, < and <--).
>
> The naming system tries to be as close as possible to the one proposed
> in the paper.
>
> * module/ice-9/peg/string-peg.scm: Rewrite PEG parser.
> * test-suite/tests/peg.test: Fix import
Nice work!
Questions:
1. Is the name change for lexical elements (camel case instead of
lower-case + hyphens) user-visible? I guess no but better be safe
than sorry.
I have a preference for lower-case + hyphens out of consistency
with the rest of Scheme, but I can see how keeping the same names
as in the reference material helps.
2. Could you add tests for the missing features that this adds, and
maybe extend ‘api-peg.texi’ accordingly too?
3. You can choose to assign copyright to the FSF or to not do that¹.
In the latter case, please add a copyright line for you where
appropriate.
I’m really not a PEG expert though so I’d prefer more eyeballs here, but
I trust your judgment.
There are three (guix import *) modules that use (ice-9 peg) and that
come with tests. It would be nice to check that those tests still pass
with the modified string-peg.scm.
Thanks!
Ludo’.
¹ https://lists.gnu.org/archive/html/guile-devel/2022-10/msg00008.html
^ permalink raw reply [flat|nested] 7+ messages in thread
* bug#73188: PEG parser does not support full PEG grammar
2024-10-13 20:29 ` bug#73188: PEG parser does not support full PEG grammar Ludovic Courtès
@ 2024-10-13 20:59 ` Ekaitz Zarraga
2024-10-14 11:56 ` Ludovic Courtès
0 siblings, 1 reply; 7+ messages in thread
From: Ekaitz Zarraga @ 2024-10-13 20:59 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 73188
Saluton Ludovic,
On 2024-10-13 22:29, Ludovic Courtès wrote:
> Hi Ekaitz,
>
> Ekaitz Zarraga <ekaitz@elenq.tech> skribis:
>
>> This commit adds support for PEG as described in:
>>
>> <https://bford.info/pub/lang/peg.pdf>
>
> I would make this a comment below the ‘define-module’ form.
Okay I will add it.
>> It adds support for the missing features (comments, underscores in
>> identifiers and escaping) while keeping the extensions (dashes in
>> identifiers, < and <--).
>>
>> The naming system tries to be as close as possible to the one proposed
>> in the paper.
>>
>> * module/ice-9/peg/string-peg.scm: Rewrite PEG parser.
>> * test-suite/tests/peg.test: Fix import
>
> Nice work!
Thank you
> Questions:
>
> 1. Is the name change for lexical elements (camel case instead of
> lower-case + hyphens) user-visible? I guess no but better be safe
> than sorry.
I think they can be, in a very weird way. If using `peg-as-peg` or
something they can be used, but the ones coming from the PEG in text,
which makes way more sense written like in the paper. I'm not sure if
there's another way to make them available, but I don't think there is.
I exported `Grammar` as `peg-grammar` because of this. So the users
should just use `peg-grammar` for their things.
> I have a preference for lower-case + hyphens out of consistency
> with the rest of Scheme, but I can see how keeping the same names
> as in the reference material helps.
Yeah, I wasn't sure about it. And I'm still not very sure. But I think
keeping the same names the paper does helps.
> 2. Could you add tests for the missing features that this adds, and
> maybe extend ‘api-peg.texi’ accordingly too?
It doesn't really add much new in this first case, but it makes it work
as expected in PEG, which is what documentation already claimed to do,
and the code didn't actually implement. Mostly what this commit adds is
escaping support in the PEG string literals.
> 3. You can choose to assign copyright to the FSF or to not do that¹.
> In the latter case, please add a copyright line for you where
> appropriate.
I don't care (maybe I should?). I just want this to work properly.
> I’m really not a PEG expert though so I’d prefer more eyeballs here, but
> I trust your judgment.
I don't know how wise this is :)
> There are three (guix import *) modules that use (ice-9 peg) and that
> come with tests. It would be nice to check that those tests still pass
> with the modified string-peg.scm.
This is very interesting and I didn't know. All tests from Guile pass,
but I'll try these and report here.
> Thanks!
>
> Ludo’.
>
> ¹ https://lists.gnu.org/archive/html/guile-devel/2022-10/msg00008.html
Thanks for the review, Ludo.
Next days I plan to review some older patches in the mailing list that
offer a very straightforward solution for error reporting and try to
include them with this and the extra features I added.
For the time being, I'll review what you mentioned, rebase the support
for `[^...]` and resend them together.
I appreciate your time spent here, Ludo. Really.
^ permalink raw reply [flat|nested] 7+ messages in thread
* bug#73188: PEG parser does not support full PEG grammar
2024-10-13 20:59 ` Ekaitz Zarraga
@ 2024-10-14 11:56 ` Ludovic Courtès
2024-10-14 14:00 ` Ekaitz Zarraga
0 siblings, 1 reply; 7+ messages in thread
From: Ludovic Courtès @ 2024-10-14 11:56 UTC (permalink / raw)
To: Ekaitz Zarraga; +Cc: 73188
Saluton!
Ekaitz Zarraga <ekaitz@elenq.tech> skribis:
> On 2024-10-13 22:29, Ludovic Courtès wrote:
>> Hi Ekaitz,
>> Ekaitz Zarraga <ekaitz@elenq.tech> skribis:
[...]
>>> It adds support for the missing features (comments, underscores in
>>> identifiers and escaping) while keeping the extensions (dashes in
>>> identifiers, < and <--).
>>>
>>> The naming system tries to be as close as possible to the one proposed
>>> in the paper.
>>>
>>> * module/ice-9/peg/string-peg.scm: Rewrite PEG parser.
>>> * test-suite/tests/peg.test: Fix import
[...]
>> 1. Is the name change for lexical elements (camel case instead of
>> lower-case + hyphens) user-visible? I guess no but better be safe
>> than sorry.
>
> I think they can be, in a very weird way. If using `peg-as-peg` or
> something they can be used, but the ones coming from the PEG in text,
> which makes way more sense written like in the paper. I'm not sure if
> there's another way to make them available, but I don't think there
> is.
>
> I exported `Grammar` as `peg-grammar` because of this. So the users
> should just use `peg-grammar` for their things.
Sounds good. As long as we don’t unwillingly introduce API
incompatibilities, that is fine.
>> 2. Could you add tests for the missing features that this adds, and
>> maybe extend ‘api-peg.texi’ accordingly too?
>
> It doesn't really add much new in this first case, but it makes it
> work as expected in PEG, which is what documentation already claimed
> to do, and the code didn't actually implement. Mostly what this commit
> adds is escaping support in the PEG string literals.
I was referring to the features mentioned in the commit log, namely
comments, underscores in identifiers, and escaping.
>> 3. You can choose to assign copyright to the FSF or to not do that¹.
>> In the latter case, please add a copyright line for you where
>> appropriate.
>
> I don't care (maybe I should?). I just want this to work properly.
So, copyright line I guess. :-)
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 7+ messages in thread
* bug#73188: PEG parser does not support full PEG grammar
2024-10-14 11:56 ` Ludovic Courtès
@ 2024-10-14 14:00 ` Ekaitz Zarraga
0 siblings, 0 replies; 7+ messages in thread
From: Ekaitz Zarraga @ 2024-10-14 14:00 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 73188
[-- Attachment #1: Type: text/plain, Size: 2157 bytes --]
Hi,
So I reviewed the suggestions and this what I have:
- Added the comment
- Added my copyright line
- Nothing in Guix is affected by the changes proposed here, because
there's no use of `string-peg` and I didn't change how the S-Expression
based PEG works.
- The changes applied here only affect to the PEG written as PEG strings
and their processing, which was introduced in the documentation as "read
the wikipedia", but our PEG definition wasn't implementing the real PEG
explained in that wikipedia link. Our documentation claimed that we were
able to do things we were not able to do.
- I added a link to the paper we are following below the link to the
wikipedia page just in case, to let our users know exactly what does our
PEG support. The paper says:
Literals and character classes can contain C-like escape codes
That should be enough for anyone. Also we support `-` in identifiers,
but our documentation already said that. I replaced the description of
what normal PEG supports. Our docs said PEG only supported alphabetic
characters but it has never been true, the paper explains PEG supports
alpha, numeric and `_`, but the numeric cannot be the first character
(like C identifiers).
- What it is true is if people were using `peg-as-peg` for their things,
which isn't even exported by the module, their code would have problems.
But we can't predict that.
- In summary, what I implemented here is a PEG string to PEG Sexp
compiler. So it shouldn't affect anyone that uses the PEG Sexp directly
and if I did my work properly it shouldn't affect those that used their
PEG patterns in strings either, because I only made it work closely to
what the paper said, adding a couple of missing features.
EXTRA:
I rebased the support for the `not-in-range` part, that does touch the
PEG sexp part, but only adds more functionality without affecting
anything that already existed.
In following days I'll review Error reporting and captures that were
added in a different thread in guile-devel and see if we can integrate
everything to create a production ready PEG parser.
Thanks!
Ekaitz
I attached both patches.
[-- Attachment #2: v3-0001-PEG-Add-full-support-for-PEG-some-extensions.patch --]
[-- Type: text/x-patch, Size: 21671 bytes --]
From 81944c2037e0d6d8c972def2ceb1aa4c51a61431 Mon Sep 17 00:00:00 2001
From: Ekaitz Zarraga <ekaitz@elenq.tech>
Date: Wed, 11 Sep 2024 21:19:26 +0200
Subject: [PATCH v3 1/2] PEG: Add full support for PEG + some extensions
This commit adds support for PEG as described in:
<https://bford.info/pub/lang/peg.pdf>
It adds support for the missing features (comments, underscores in
identifiers and escaping) while keeping the extensions (dashes in
identifiers, < and <--).
The naming system tries to be as close as possible to the one proposed
in the paper.
* module/ice-9/peg/string-peg.scm: Rewrite PEG parser.
* test-suite/tests/peg.test: Fix import
---
doc/ref/api-peg.texi | 8 +-
module/ice-9/peg/string-peg.scm | 442 ++++++++++++++++++++------------
test-suite/tests/peg.test | 32 ++-
3 files changed, 302 insertions(+), 180 deletions(-)
diff --git a/doc/ref/api-peg.texi b/doc/ref/api-peg.texi
index d34ddc64c..84a9e6c6b 100644
--- a/doc/ref/api-peg.texi
+++ b/doc/ref/api-peg.texi
@@ -17,6 +17,10 @@ Wikipedia has a clear and concise introduction to PEGs if you want to
familiarize yourself with the syntax:
@url{http://en.wikipedia.org/wiki/Parsing_expression_grammar}.
+The paper that introduced PEG contains a more detailed description of how PEG
+works, and describes its syntax in detail:
+@url{https://bford.info/pub/lang/peg.pdf}
+
The @code{(ice-9 peg)} module works by compiling PEGs down to lambda
expressions. These can either be stored in variables at compile-time by
the define macros (@code{define-peg-pattern} and
@@ -216,8 +220,8 @@ should propagate up the parse tree. The normal @code{<-} propagates the
matched text up the parse tree, @code{<--} propagates the matched text
up the parse tree tagged with the name of the nonterminal, and @code{<}
discards that matched text and propagates nothing up the parse tree.
-Also, nonterminals may consist of any alphanumeric character or a ``-''
-character (in normal PEGs nonterminals can only be alphabetic).
+Also, nonterminals may include ``-'' character, while in normal PEG it is not
+allowed.
For example, if we:
@lisp
diff --git a/module/ice-9/peg/string-peg.scm b/module/ice-9/peg/string-peg.scm
index 45ed14bb1..f688653ef 100644
--- a/module/ice-9/peg/string-peg.scm
+++ b/module/ice-9/peg/string-peg.scm
@@ -1,6 +1,7 @@
;;;; string-peg.scm --- representing PEG grammars as strings
;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, Free Software Foundation, Inc.
+;;;; Copyright (C) 2024 Ekaitz Zarraga <ekaitz@elenq.tech>
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -22,9 +23,13 @@
define-peg-string-patterns
peg-grammar)
#:use-module (ice-9 peg using-parsers)
+ #:use-module (srfi srfi-1)
#:use-module (ice-9 peg codegen)
#:use-module (ice-9 peg simplify-tree))
+;; This module provides support for PEG as described in:
+;; <https://bford.info/pub/lang/peg.pdf>
+
;; Gets the left-hand depth of a list.
(define (depth lst)
(if (or (not (list? lst)) (null? lst))
@@ -38,22 +43,57 @@
;; Grammar for PEGs in PEG grammar.
(define peg-as-peg
-"grammar <-- (nonterminal ('<--' / '<-' / '<') sp pattern)+
-pattern <-- alternative (SLASH sp alternative)*
-alternative <-- ([!&]? sp suffix)+
-suffix <-- primary ([*+?] sp)*
-primary <-- '(' sp pattern ')' sp / '.' sp / literal / charclass / nonterminal !'<'
-literal <-- ['] (!['] .)* ['] sp
-charclass <-- LB (!']' (CCrange / CCsingle))* RB sp
-CCrange <-- . '-' .
-CCsingle <-- .
-nonterminal <-- [a-zA-Z0-9-]+ sp
-sp < [ \t\n]*
-SLASH < '/'
-LB < '['
-RB < ']'
+"# Hierarchical syntax
+Grammar <-- Spacing Definition+ EndOfFile
+Definition <-- Identifier LEFTARROW Expression
+
+Expression <-- Sequence (SLASH Sequence)*
+Sequence <-- Prefix*
+Prefix <-- (AND / NOT)? Suffix
+Suffix <-- Primary (QUESTION / STAR / PLUS)?
+Primary <-- Identifier !LEFTARROW
+ / OPEN Expression CLOSE
+ / Literal / Class / DOT
+
+# Lexical syntax
+Identifier <-- IdentStart IdentCont* Spacing
+# NOTE: `-` is an extension
+IdentStart <- [a-zA-Z_] / '-'
+IdentCont <- IdentStart / [0-9]
+
+Literal <-- SQUOTE (!SQUOTE Char)* SQUOTE Spacing
+ / DQUOTE (!DQUOTE Char)* DQUOTE Spacing
+Class <-- '[' (!']' Range)* ']' Spacing
+Range <-- Char '-' Char / Char
+Char <-- '\\\\' [nrt'\"\\[\\]\\\\]
+ / '\\\\' [0-7][0-7][0-7]
+ / '\\\\' [0-7][0-7]?
+ / !'\\\\' .
+
+# NOTE: `<--` and `<` are extensions
+LEFTARROW <- ('<--' / '<-' / '<') Spacing
+SQUOTE <-- [']
+DQUOTE <-- [\"]
+OPENBRACKET < '['
+CLOSEBRACKET < ']'
+SLASH < '/' Spacing
+AND <-- '&' Spacing
+NOT <-- '!' Spacing
+QUESTION <-- '?' Spacing
+STAR <-- '*' Spacing
+PLUS <-- '+' Spacing
+OPEN < '(' Spacing
+CLOSE < ')' Spacing
+DOT <-- '.' Spacing
+
+Spacing < (Space / Comment)*
+Comment < '#' (!EndOfLine .)* EndOfLine
+Space < ' ' / '\t' / EndOfLine
+EndOfLine < '\\r\\n' / '\\n' / '\\r'
+EndOfFile < !.
")
+
(define-syntax define-sexp-parser
(lambda (x)
(syntax-case x ()
@@ -63,35 +103,78 @@ RB < ']'
(syn (wrap-parser-for-users x matchf accumsym #'sym)))
#`(define sym #,syn))))))
-(define-sexp-parser peg-grammar all
- (+ (and peg-nonterminal (or "<--" "<-" "<") peg-sp peg-pattern)))
-(define-sexp-parser peg-pattern all
- (and peg-alternative
- (* (and (ignore "/") peg-sp peg-alternative))))
-(define-sexp-parser peg-alternative all
- (+ (and (? (or "!" "&")) peg-sp peg-suffix)))
-(define-sexp-parser peg-suffix all
- (and peg-primary (* (and (or "*" "+" "?") peg-sp))))
-(define-sexp-parser peg-primary all
- (or (and "(" peg-sp peg-pattern ")" peg-sp)
- (and "." peg-sp)
- peg-literal
- peg-charclass
- (and peg-nonterminal (not-followed-by "<"))))
-(define-sexp-parser peg-literal all
- (and "'" (* (and (not-followed-by "'") peg-any)) "'" peg-sp))
-(define-sexp-parser peg-charclass all
- (and (ignore "[")
- (* (and (not-followed-by "]")
- (or charclass-range charclass-single)))
- (ignore "]")
- peg-sp))
-(define-sexp-parser charclass-range all (and peg-any "-" peg-any))
-(define-sexp-parser charclass-single all peg-any)
-(define-sexp-parser peg-nonterminal all
- (and (+ (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) "-")) peg-sp))
-(define-sexp-parser peg-sp none
- (* (or " " "\t" "\n")))
+(define-sexp-parser Grammar all
+ (and Spacing (+ Definition) EndOfFile))
+(define-sexp-parser Definition all
+ (and Identifier LEFTARROW Expression))
+(define-sexp-parser Expression all
+ (and Sequence (* (and SLASH Sequence))))
+(define-sexp-parser Sequence all
+ (* Prefix))
+(define-sexp-parser Prefix all
+ (and (? (or AND NOT)) Suffix))
+(define-sexp-parser Suffix all
+ (and Primary (? (or QUESTION STAR PLUS))))
+(define-sexp-parser Primary all
+ (or (and Identifier (not-followed-by LEFTARROW))
+ (and OPEN Expression CLOSE)
+ Literal
+ Class
+ DOT))
+(define-sexp-parser Identifier all
+ (and IdentStart (* IdentCont) Spacing))
+(define-sexp-parser IdentStart body
+ (or (range #\a #\z) (range #\A #\Z) "_" "-")) ; NOTE: - is an extension
+(define-sexp-parser IdentCont body
+ (or IdentStart (range #\0 #\9)))
+(define-sexp-parser Literal all
+ (or (and SQUOTE (* (and (not-followed-by SQUOTE) Char)) SQUOTE Spacing)
+ (and DQUOTE (* (and (not-followed-by DQUOTE) Char)) DQUOTE Spacing)))
+(define-sexp-parser Class all
+ (and OPENBRACKET (* (and (not-followed-by CLOSEBRACKET) Range)) CLOSEBRACKET Spacing))
+(define-sexp-parser Range all
+ (or (and Char DASH Char) Char))
+(define-sexp-parser Char all
+ (or (and "\\" (or "n" "r" "t" "'" "[" "]" "\\"))
+ (and "\\" (range #\0 #\7) (range #\0 #\7) (range #\0 #\7))
+ (and "\\" (range #\0 #\7) (? (range #\0 #\7)))
+ (and (not-followed-by "\\") peg-any)))
+(define-sexp-parser LEFTARROW body
+ (and (or "<--" "<-" "<") Spacing)) ; NOTE: <-- and < are extensions
+(define-sexp-parser SLASH none
+ (and "/" Spacing))
+(define-sexp-parser AND all
+ (and "&" Spacing))
+(define-sexp-parser NOT all
+ (and "!" Spacing))
+(define-sexp-parser QUESTION all
+ (and "?" Spacing))
+(define-sexp-parser STAR all
+ (and "*" Spacing))
+(define-sexp-parser PLUS all
+ (and "+" Spacing))
+(define-sexp-parser OPEN none
+ (and "(" Spacing))
+(define-sexp-parser CLOSE none
+ (and ")" Spacing))
+(define-sexp-parser DOT all
+ (and "." Spacing))
+(define-sexp-parser SQUOTE none "'")
+(define-sexp-parser DQUOTE none "\"")
+(define-sexp-parser OPENBRACKET none "[")
+(define-sexp-parser CLOSEBRACKET none "]")
+(define-sexp-parser DASH none "-")
+(define-sexp-parser Spacing none
+ (* (or Space Comment)))
+(define-sexp-parser Comment none
+ (and "#" (* (and (not-followed-by EndOfLine) peg-any)) EndOfLine))
+(define-sexp-parser Space none
+ (or " " "\t" EndOfLine))
+(define-sexp-parser EndOfLine none
+ (or "\r\n" "\n" "\r"))
+(define-sexp-parser EndOfFile none
+ (not-followed-by peg-any))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; PARSE STRING PEGS
@@ -101,7 +184,7 @@ RB < ']'
;; will define all of the nonterminals in the grammar with equivalent
;; PEG s-expressions.
(define (peg-parser str for-syntax)
- (let ((parsed (match-pattern peg-grammar str)))
+ (let ((parsed (match-pattern Grammar str)))
(if (not parsed)
(begin
;; (display "Invalid PEG grammar!\n")
@@ -110,132 +193,160 @@ RB < ']'
(cond
((or (not (list? lst)) (null? lst))
lst)
- ((eq? (car lst) 'peg-grammar)
- #`(begin
- #,@(map (lambda (x) (peg-nonterm->defn x for-syntax))
- (context-flatten (lambda (lst) (<= (depth lst) 2))
- (cdr lst))))))))))
+ ((eq? (car lst) 'Grammar)
+ (Grammar->defn lst for-syntax)))))))
-;; Macro wrapper for PEG-PARSER. Parses PEG grammars expressed as strings and
-;; defines all the appropriate nonterminals.
-(define-syntax define-peg-string-patterns
- (lambda (x)
- (syntax-case x ()
- ((_ str)
- (peg-parser (syntax->datum #'str) x)))))
+;; (Grammar (Definition ...) (Definition ...))
+(define (Grammar->defn lst for-syntax)
+ #`(begin
+ #,@(map (lambda (x) (Definition->defn x for-syntax))
+ (context-flatten (lambda (lst) (<= (depth lst) 1))
+ (cdr lst)))))
-;; lst has format (nonterm grabber pattern), where
-;; nonterm is a symbol (the name of the nonterminal),
-;; grabber is a string (either "<", "<-" or "<--"), and
-;; pattern is the parse of a PEG pattern expressed as as string.
-(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-peg-pattern #,nonterm-name
+;; (Definition (Identifier "Something") "<-" (Expression ...))
+;; `-> (define-peg-pattern Something 'all ...)
+(define (Definition->defn lst for-syntax)
+ (let ((identifier (second (second lst)))
+ (grabber (third lst))
+ (expression (fourth lst)))
+ #`(define-peg-pattern #,(datum->syntax for-syntax
+ (string->symbol identifier))
#,(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))))
-
-;; lst has format ('peg-pattern ...).
-;; After the context-flatten, (cdr lst) has format
-;; (('peg-alternative ...) ...), where the outer list is a collection
-;; of elements from a '/' alternative.
-(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)))))
-
-;; lst has format ('peg-alternative ...).
-;; After the context-flatten, (cdr lst) has the format
-;; (item ...), where each item has format either ("!" ...), ("&" ...),
-;; or ('peg-suffix ...).
-(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)))))
-
-;; lst has the format either
-;; ("!" ('peg-suffix ...)), ("&" ('peg-suffix ...)), or
-;; ('peg-suffix ...).
-(define (peg-body->defn lst for-syntax)
- (cond
- ((equal? (car lst) "&")
- #`(followed-by #,(peg-suffix->defn (cadr lst) for-syntax)))
- ((equal? (car lst) "!")
- #`(not-followed-by #,(peg-suffix->defn (cadr lst) for-syntax)))
- ((eq? (car lst) 'peg-suffix)
- (peg-suffix->defn lst for-syntax))
- (else `(peg-parse-body-fail ,lst))))
-
-;; lst has format ('peg-suffix <peg-primary> (? (/ "*" "?" "+")))
-(define (peg-suffix->defn lst for-syntax)
- (let ((inner-defn (peg-primary->defn (cadr lst) for-syntax)))
- (cond
- ((null? (cddr lst))
- inner-defn)
- ((equal? (caddr lst) "*")
- #`(* #,inner-defn))
- ((equal? (caddr lst) "?")
- #`(? #,inner-defn))
- ((equal? (caddr lst) "+")
- #`(+ #,inner-defn)))))
-
-;; Parse a primary.
-(define (peg-primary->defn lst for-syntax)
- (let ((el (cadr lst)))
+ #,(compressor (Expression->defn expression for-syntax) for-syntax))))
+
+;; (Expression (Sequence X))
+;; `-> (X)
+;; (Expression (Sequence X) (Sequence Y))
+;; `-> (or X Y)
+;; (Expression (Sequence X) ((Sequence Y) (Sequence Z) ...))
+;; `-> (or X Y Z ...)
+(define (Expression->defn lst for-syntax)
+ (let ((first-sequence (second lst))
+ (rest (cddr lst)))
+ #`(or #,(Sequence->defn first-sequence for-syntax)
+ #,@(map (lambda (x)
+ (Sequence->defn x for-syntax))
+ (keyword-flatten '(Sequence) rest)))))
+
+
+(define (Sequence->defn lst for-syntax)
+ #`(and #,@(map (lambda (x) (Prefix->defn x for-syntax)) (cdr lst))))
+
+
+;; (Prefix (Suffix ...))
+;; `-> (...)
+;; (Prefix (NOT "!") (Suffix ...))
+;; `-> (not-followed-by ...)
+;; (Prefix (AND "&") (Suffix ...))
+;; `-> (followed-by ...)
+(define (Prefix->defn lst for-syntax)
+ (let ((suffix (second lst)))
+ (case (car suffix)
+ ('AND #`(followed-by #,(Suffix->defn (third lst) for-syntax)))
+ ('NOT #`(not-followed-by #,(Suffix->defn (third lst) for-syntax)))
+ (else (Suffix->defn suffix for-syntax)))))
+
+;; (Suffix (Primary ...))
+;; `-> (...)
+;; (Suffix (Primary ...) (STAR "*"))
+;; `-> (* ...)
+;; (Suffix (Primary ...) (QUESTION "?"))
+;; `-> (? ...)
+;; (Suffix (Primary ...) (PLUS "+"))
+;; `-> (+ ...)
+(define (Suffix->defn lst for-syntax)
+ (let* ((primary (second lst))
+ (out (Primary->defn primary for-syntax))
+ (extra (cddr lst)))
+ (if (null? extra)
+ out
+ (case (caar extra)
+ ('QUESTION #`(? #,out))
+ ('STAR #`(* #,out))
+ ('PLUS #`(+ #,out))))))
+
+(define (Primary->defn lst for-syntax)
+ (let ((value (second lst)))
+ (case (car value)
+ ('DOT #'peg-any)
+ ('Identifier (Identifier->defn value for-syntax))
+ ('Expression (Expression->defn value for-syntax))
+ ('Literal (Literal->defn value for-syntax))
+ ('Class (Class->defn value for-syntax)))))
+
+;; (Identifier "hello")
+;; `-> hello
+(define (Identifier->defn lst for-syntax)
+ (datum->syntax for-syntax (string->symbol (second lst))))
+
+;; (Literal (Char "a") (Char "b") (Char "c"))
+;; `-> "abc"
+(define (Literal->defn lst for-syntax)
+ (apply string (map (lambda (x) (Char->defn x for-syntax)) (cdr lst))))
+
+;; TODO: empty Class can happen: `[]`, but what does it represent?
+;; (Class ...)
+;; `-> (or ...)
+(define (Class->defn lst for-syntax)
+ #`(or #,@(map (lambda (x) (Range->defn x for-syntax))
+ (cdr lst))))
+
+;; For one character:
+;; (Range (Char "a"))
+;; `-> "a"
+;; Or for a range:
+;; (Range (Char "a") (Char "b"))
+;; `-> (range #\a #\b)
+(define (Range->defn lst for-syntax)
(cond
- ((list? el)
- (cond
- ((eq? (car el) 'peg-literal)
- (peg-literal->defn el for-syntax))
- ((eq? (car el) 'peg-charclass)
- (peg-charclass->defn el for-syntax))
- ((eq? (car el) 'peg-nonterminal)
- (datum->syntax for-syntax (string->symbol (cadr el))))))
- ((string? el)
+ ((= 2 (length lst))
+ (second (second lst)))
+ ((= 3 (length lst))
+ #`(range
+ #,(Char->defn (second lst) for-syntax)
+ #,(Char->defn (third lst) for-syntax)))))
+
+;; (Char "a")
+;; `-> #\a
+;; (Char "\\n")
+;; `-> #\newline
+;; (Char "\\135")
+;; `-> #\]
+(define (Char->defn lst for-syntax)
+ (let* ((charstr (second lst))
+ (first (string-ref charstr 0)))
(cond
- ((equal? el "(")
- (peg-pattern->defn (caddr lst) for-syntax))
- ((equal? el ".")
- (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))))))
-
-;; Trims characters off the front and end of STR.
-;; (trim-1chars "'ab'") -> "ab"
-(define (trim-1chars str) (substring str 1 (- (string-length str) 1)))
-
-;; Parses a literal.
-(define (peg-literal->defn lst for-syntax)
- (datum->syntax for-syntax (trim-1chars (cadr lst))))
-
-;; Parses a charclass.
-(define (peg-charclass->defn lst for-syntax)
- #`(or
- #,@(map
- (lambda (cc)
- (cond
- ((eq? (car cc) 'charclass-range)
- #`(range #,(datum->syntax
- for-syntax
- (string-ref (cadr cc) 0))
- #,(datum->syntax
- for-syntax
- (string-ref (cadr cc) 2))))
- ((eq? (car cc) 'charclass-single)
- (datum->syntax for-syntax (cadr cc)))))
- (context-flatten
- (lambda (x) (or (eq? (car x) 'charclass-range)
- (eq? (car x) 'charclass-single)))
- (cdr lst)))))
+ ((= 1 (string-length charstr)) first)
+ ((char-numeric? (string-ref charstr 1))
+ (integer->char
+ (reduce + 0
+ (map
+ (lambda (x y)
+ (* (- (char->integer x) (char->integer #\0)) y))
+ (reverse (string->list charstr 1))
+ '(1 8 64)))))
+ (else
+ (case (string-ref charstr 1)
+ ((#\n) #\newline)
+ ((#\r) #\return)
+ ((#\t) #\tab)
+ ((#\') #\')
+ ((#\]) #\])
+ ((#\\) #\\)
+ ((#\[) #\[))))))
+
+(define peg-grammar Grammar)
+
+;; Macro wrapper for PEG-PARSER. Parses PEG grammars expressed as strings and
+;; defines all the appropriate nonterminals.
+(define-syntax define-peg-string-patterns
+ (lambda (x)
+ (syntax-case x ()
+ ((_ str)
+ (peg-parser (syntax->datum #'str) x)))))
;; Compresses a list to save the optimizer work.
;; e.g. (or (and a)) -> a
@@ -263,11 +374,10 @@ RB < ']'
(let ((string (syntax->datum #'str-stx)))
(compile-peg-pattern
(compressor
- (peg-pattern->defn
- (peg:tree (match-pattern peg-pattern string)) #'str-stx)
+ (Expression->defn
+ (peg:tree (match-pattern Expression string)) #'str-stx)
#'str-stx)
(if (eq? accum 'all) 'body accum))))
(else (error "Bad embedded PEG string" args))))
(add-peg-compiler! 'peg peg-string-compile)
-
diff --git a/test-suite/tests/peg.test b/test-suite/tests/peg.test
index f516571e8..556145e72 100644
--- a/test-suite/tests/peg.test
+++ b/test-suite/tests/peg.test
@@ -28,17 +28,25 @@
;; the nonterminals defined in the PEG parser written with
;; S-expressions.
(define grammar-mapping
- '((grammar peg-grammar)
- (pattern peg-pattern)
- (alternative peg-alternative)
- (suffix peg-suffix)
- (primary peg-primary)
- (literal peg-literal)
- (charclass peg-charclass)
- (CCrange charclass-range)
- (CCsingle charclass-single)
- (nonterminal peg-nonterminal)
- (sp peg-sp)))
+ '((Grammar Grammar)
+ (Definition Definition)
+ (Expression Expression)
+ (Sequence Sequence)
+ (Prefix Prefix)
+ (Suffix Suffix)
+ (Primary Primary)
+ (Identifier Identifier)
+ (Literal Literal)
+ (Class Class)
+ (Range Range)
+ (Char Char)
+ (LEFTARROW LEFTARROW)
+ (AND AND)
+ (NOT NOT)
+ (QUESTION QUESTION)
+ (STAR STAR)
+ (PLUS PLUS)
+ (DOT DOT)))
;; Transforms the nonterminals defined in the PEG parser written as a PEG to the nonterminals defined in the PEG parser written with S-expressions.
(define (grammar-transform x)
@@ -69,7 +77,7 @@
(peg:tree (match-pattern (@@ (ice-9 peg) peg-grammar) (@@ (ice-9 peg) peg-as-peg)))
(tree-map
grammar-transform
- (peg:tree (match-pattern grammar (@@ (ice-9 peg) peg-as-peg)))))))
+ (peg:tree (match-pattern (@@ (ice-9 peg) peg-grammar) (@@ (ice-9 peg) peg-as-peg)))))))
;; A grammar for pascal-style comments from Wikipedia.
(define comment-grammar
--
2.46.0
[-- Attachment #3: v3-0002-PEG-Add-support-for-not-in-range-and.patch --]
[-- Type: text/x-patch, Size: 7693 bytes --]
From 64a17be08581465d11185b4a0ca636354d2f944c Mon Sep 17 00:00:00 2001
From: Ekaitz Zarraga <ekaitz@elenq.tech>
Date: Fri, 11 Oct 2024 14:24:30 +0200
Subject: [PATCH v3 2/2] PEG: Add support for `not-in-range` and [^...]
Modern PEG supports inversed class like `[^a-z]` that would get any
character not in the `a-z` range. This commit adds support for that and
also for a new `not-in-range` PEG pattern for scheme.
* module/ice-9/peg/codegen.scm (cg-not-in-range): New function.
* module/ice-9/peg/string-peg.scm: Add support for `[^...]`
* test-suite/tests/peg.test: Test it.
* doc/ref/api-peg.texi: Document accordingly.
---
doc/ref/api-peg.texi | 8 +++++++
module/ice-9/peg/codegen.scm | 22 +++++++++++++++++++
module/ice-9/peg/string-peg.scm | 39 +++++++++++++++++++++++++++++----
test-suite/tests/peg.test | 6 ++++-
4 files changed, 70 insertions(+), 5 deletions(-)
diff --git a/doc/ref/api-peg.texi b/doc/ref/api-peg.texi
index 84a9e6c6b..edb090b20 100644
--- a/doc/ref/api-peg.texi
+++ b/doc/ref/api-peg.texi
@@ -147,6 +147,14 @@ Parses any character falling between @var{a} and @var{z}.
@code{(range #\a #\z)}
@end deftp
+@deftp {PEG Pattern} {inverse range of characters} a z
+Parses any character not falling between @var{a} and @var{z}.
+
+@code{"[^a-z]"}
+
+@code{(not-in-range #\a #\z)}
+@end deftp
+
Example:
@example
diff --git a/module/ice-9/peg/codegen.scm b/module/ice-9/peg/codegen.scm
index d80c3e849..82367ef55 100644
--- a/module/ice-9/peg/codegen.scm
+++ b/module/ice-9/peg/codegen.scm
@@ -140,6 +140,27 @@ return EXP."
((none) #`(list (1+ pos) '()))
(else (error "bad accum" accum))))))))))
+;; Generates code for matching a range of characters not between start and end.
+;; E.g.: (cg-not-in-range syntax #\a #\z 'body)
+(define (cg-not-in-range pat accum)
+ (syntax-case pat ()
+ ((start end)
+ (if (not (and (char? (syntax->datum #'start))
+ (char? (syntax->datum #'end))))
+ (error "range PEG should have characters after it; instead got"
+ #'start #'end))
+ #`(lambda (str len pos)
+ (and (< pos len)
+ (let ((c (string-ref str pos)))
+ (and (or (char<? c start) (char>? c end))
+ #,(case accum
+ ((all) #`(list (1+ pos)
+ (list 'cg-not-in-range (string c))))
+ ((name) #`(list (1+ pos) 'cg-not-in-range))
+ ((body) #`(list (1+ pos) (string c)))
+ ((none) #`(list (1+ pos) '()))
+ (else (error "bad accum" accum))))))))))
+
;; Generate code to match a pattern and do nothing with the result
(define (cg-ignore pat accum)
(syntax-case pat ()
@@ -304,6 +325,7 @@ return EXP."
(assq-set! peg-compiler-alist symbol function)))
(add-peg-compiler! 'range cg-range)
+(add-peg-compiler! 'not-in-range cg-not-in-range)
(add-peg-compiler! 'ignore cg-ignore)
(add-peg-compiler! 'capture cg-capture)
(add-peg-compiler! 'and cg-and)
diff --git a/module/ice-9/peg/string-peg.scm b/module/ice-9/peg/string-peg.scm
index f688653ef..2d2f972ff 100644
--- a/module/ice-9/peg/string-peg.scm
+++ b/module/ice-9/peg/string-peg.scm
@@ -53,7 +53,7 @@ Prefix <-- (AND / NOT)? Suffix
Suffix <-- Primary (QUESTION / STAR / PLUS)?
Primary <-- Identifier !LEFTARROW
/ OPEN Expression CLOSE
- / Literal / Class / DOT
+ / Literal / Class / NotInClass / DOT
# Lexical syntax
Identifier <-- IdentStart IdentCont* Spacing
@@ -63,7 +63,8 @@ IdentCont <- IdentStart / [0-9]
Literal <-- SQUOTE (!SQUOTE Char)* SQUOTE Spacing
/ DQUOTE (!DQUOTE Char)* DQUOTE Spacing
-Class <-- '[' (!']' Range)* ']' Spacing
+NotInClass <-- '[' NOTIN (!']' Range)* ']' Spacing
+Class <-- '[' !NOTIN (!']' Range)* ']' Spacing
Range <-- Char '-' Char / Char
Char <-- '\\\\' [nrt'\"\\[\\]\\\\]
/ '\\\\' [0-7][0-7][0-7]
@@ -76,6 +77,7 @@ SQUOTE <-- [']
DQUOTE <-- [\"]
OPENBRACKET < '['
CLOSEBRACKET < ']'
+NOTIN < '^'
SLASH < '/' Spacing
AND <-- '&' Spacing
NOT <-- '!' Spacing
@@ -120,6 +122,7 @@ EndOfFile < !.
(and OPEN Expression CLOSE)
Literal
Class
+ NotInClass
DOT))
(define-sexp-parser Identifier all
(and IdentStart (* IdentCont) Spacing))
@@ -131,7 +134,11 @@ EndOfFile < !.
(or (and SQUOTE (* (and (not-followed-by SQUOTE) Char)) SQUOTE Spacing)
(and DQUOTE (* (and (not-followed-by DQUOTE) Char)) DQUOTE Spacing)))
(define-sexp-parser Class all
- (and OPENBRACKET (* (and (not-followed-by CLOSEBRACKET) Range)) CLOSEBRACKET Spacing))
+ (and OPENBRACKET (not-followed-by NOTIN)
+ (* (and (not-followed-by CLOSEBRACKET) Range)) CLOSEBRACKET Spacing))
+(define-sexp-parser NotInClass all
+ (and OPENBRACKET NOTIN
+ (* (and (not-followed-by CLOSEBRACKET) Range)) CLOSEBRACKET Spacing))
(define-sexp-parser Range all
(or (and Char DASH Char) Char))
(define-sexp-parser Char all
@@ -141,6 +148,8 @@ EndOfFile < !.
(and (not-followed-by "\\") peg-any)))
(define-sexp-parser LEFTARROW body
(and (or "<--" "<-" "<") Spacing)) ; NOTE: <-- and < are extensions
+(define-sexp-parser NOTIN none
+ (and "^"))
(define-sexp-parser SLASH none
(and "/" Spacing))
(define-sexp-parser AND all
@@ -275,6 +284,7 @@ EndOfFile < !.
('Identifier (Identifier->defn value for-syntax))
('Expression (Expression->defn value for-syntax))
('Literal (Literal->defn value for-syntax))
+ ('NotInClass (NotInClass->defn value for-syntax))
('Class (Class->defn value for-syntax)))))
;; (Identifier "hello")
@@ -287,13 +297,34 @@ EndOfFile < !.
(define (Literal->defn lst for-syntax)
(apply string (map (lambda (x) (Char->defn x for-syntax)) (cdr lst))))
-;; TODO: empty Class can happen: `[]`, but what does it represent?
+;; (NotInClass ...)
+;; `-> (and ...)
+(define (NotInClass->defn lst for-syntax)
+ #`(and #,@(map (lambda (x) (NotInRange->defn x for-syntax))
+ (cdr lst))))
+
;; (Class ...)
;; `-> (or ...)
(define (Class->defn lst for-syntax)
#`(or #,@(map (lambda (x) (Range->defn x for-syntax))
(cdr lst))))
+;; For one character:
+;; (NotInRange (Char "a"))
+;; `-> (not-in-range #\a #\a)
+;; Or for a range:
+;; (NotInRange (Char "a") (Char "b"))
+;; `-> (not-in-range #\a #\b)
+(define (NotInRange->defn lst for-syntax)
+ (cond
+ ((= 2 (length lst))
+ (let ((ch (Char->defn (second lst) for-syntax)))
+ #`(not-in-range #,ch #,ch)))
+ ((= 3 (length lst))
+ #`(not-in-range
+ #,(Char->defn (second lst) for-syntax)
+ #,(Char->defn (third lst) for-syntax)))))
+
;; For one character:
;; (Range (Char "a"))
;; `-> "a"
diff --git a/test-suite/tests/peg.test b/test-suite/tests/peg.test
index 556145e72..965e1c12f 100644
--- a/test-suite/tests/peg.test
+++ b/test-suite/tests/peg.test
@@ -38,6 +38,7 @@
(Identifier Identifier)
(Literal Literal)
(Class Class)
+ (NotInClass NotInClass)
(Range Range)
(Char Char)
(LEFTARROW LEFTARROW)
@@ -85,7 +86,7 @@
End <-- '*)'
C <- Begin N* End
N <- C / (!Begin !End Z)
-Z <- .")
+Z <- [^X-Z]") ;; Forbid some characters to test not-in-range
;; A short /etc/passwd file.
(define *etc-passwd*
@@ -125,6 +126,9 @@ SLASH < '/'")
(match-pattern C "(*blah*)")
(make-prec 0 8 "(*blah*)"
'((Begin "(*") "blah" (End "*)")))))
+ (pass-if
+ "simple comment with forbidden char"
+ (not (match-pattern C "(*blYh*)")))
(pass-if
"simple comment padded"
(equal?
--
2.46.0
^ permalink raw reply related [flat|nested] 7+ messages in thread
end of thread, other threads:[~2024-10-14 14:00 UTC | newest]
Thread overview: 7+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2024-09-11 22:03 bug#73188: PEG parser does not support full PEG grammar Ekaitz Zarraga
2024-09-12 20:57 ` bug#73188: [PATCH v2] PEG: Add full support for PEG + some extensions Ekaitz Zarraga
2024-10-13 20:29 ` bug#73188: PEG parser does not support full PEG grammar Ludovic Courtès
2024-10-13 20:59 ` Ekaitz Zarraga
2024-10-14 11:56 ` Ludovic Courtès
2024-10-14 14:00 ` Ekaitz Zarraga
2024-10-11 12:31 ` bug#73188: [PATCH] PEG: Add support for `not-in-range` and [^...] Ekaitz Zarraga
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).