diff --git a/module/ice-9/peg.scm b/module/ice-9/peg.scm index b96104a23..cb79c60f8 100644 --- a/module/ice-9/peg.scm +++ b/module/ice-9/peg.scm @@ -18,8 +18,7 @@ ;;;; (define-module (ice-9 peg) - #:export (context-flatten - peg-parse + #:export (peg-parse ; define-nonterm ; define-nonterm-f peg-match @@ -28,16 +27,17 @@ peg:string peg:tree peg:substring - peg-record? - keyword-flatten) + peg-record?) ; #:export-syntax (define-nonterm) #:use-module (ice-9 peg codegen) #:use-module (ice-9 peg string-peg) + #:use-module (ice-9 peg simplify-tree) #:re-export (peg-sexp-compile define-grammar define-grammar-f - define-nonterm) - #:use-module (system base pmatch)) + define-nonterm + keyword-flatten + context-flatten)) ;;; ;;; Helper Macros @@ -52,14 +52,6 @@ execute the STMTs and try again." (or test (begin stmt stmt* ... (lp))))))) -(define-syntax single? - (syntax-rules () - "Return #t if X is a list of one element." - ((_ x) - (pmatch x - ((_) #t) - (else #f))))) - (eval-when (compile load eval) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -104,73 +96,6 @@ execute the STMTs and try again." at end string (string-collapse match)))))))))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;; POST-PROCESSING FUNCTIONS (TO CANONICALIZE MATCH TREES) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Is everything in LST true? -(define (andlst lst) - (or (null? lst) - (and (car lst) (andlst (cdr lst))))) - -;; Is LST a list of strings? -(define (string-list? lst) - (and (list? lst) (not (null? lst)) - (andlst (map string? lst)))) - -;; Groups all strings that are next to each other in LST. Used in -;; STRING-COLLAPSE. -(define (string-group lst) - (if (not (list? lst)) - lst - (if (null? lst) - '() - (let ((next (string-group (cdr lst)))) - (if (not (string? (car lst))) - (cons (car lst) next) - (if (and (not (null? next)) - (list? (car next)) - (string? (caar next))) - (cons (cons (car lst) (car next)) (cdr next)) - (cons (list (car lst)) next))))))) - - -;; Collapses all the string in LST. -;; ("a" "b" (c d) "e" "f") -> ("ab" (c d) "ef") -(define (string-collapse lst) - (if (list? lst) - (let ((res (map (lambda (x) (if (string-list? x) - (apply string-append x) - x)) - (string-group (map string-collapse lst))))) - (if (single? res) (car res) res)) - lst)) - -;; If LST is an atom, return (list LST), else return LST. -(define (mklst lst) - (if (not (list? lst)) (list lst) lst)) - -;; Takes a list and "flattens" it, using the predicate TST to know when to stop -;; instead of terminating on atoms (see tutorial). -(define (context-flatten tst lst) - (if (or (not (list? lst)) (null? lst)) - lst - (if (tst lst) - (list lst) - (apply append - (map (lambda (x) (mklst (context-flatten tst x))) - lst))))) - -;; Takes a list and "flattens" it, using the list of keywords KEYWORD-LST to -;; know when to stop at (see tutorial). -(define (keyword-flatten keyword-lst lst) - (context-flatten - (lambda (x) - (if (or (not (list? x)) (null? x)) - #t - (member (car x) keyword-lst))) - lst)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; PMATCH STRUCTURE MUNGING ;; Pretty self-explanatory. diff --git a/module/ice-9/peg/simplify-tree.scm b/module/ice-9/peg/simplify-tree.scm new file mode 100644 index 000000000..4c781a191 --- /dev/null +++ b/module/ice-9/peg/simplify-tree.scm @@ -0,0 +1,97 @@ +;;;; simplify-tree.scm --- utility functions for the PEG parser +;;;; +;;;; Copyright (C) 2010, 2011 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (ice-9 peg simplify-tree) + #:export (keyword-flatten context-flatten string-collapse) + #:use-module (system base pmatch)) + +(define-syntax single? + (syntax-rules () + "Return #t if X is a list of one element." + ((_ x) + (pmatch x + ((_) #t) + (else #f))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; POST-PROCESSING FUNCTIONS (TO CANONICALIZE MATCH TREES) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Is everything in LST true? +(define (andlst lst) + (or (null? lst) + (and (car lst) (andlst (cdr lst))))) + +;; Is LST a list of strings? +(define (string-list? lst) + (and (list? lst) (not (null? lst)) + (andlst (map string? lst)))) + +;; Groups all strings that are next to each other in LST. Used in +;; STRING-COLLAPSE. +(define (string-group lst) + (if (not (list? lst)) + lst + (if (null? lst) + '() + (let ((next (string-group (cdr lst)))) + (if (not (string? (car lst))) + (cons (car lst) next) + (if (and (not (null? next)) + (list? (car next)) + (string? (caar next))) + (cons (cons (car lst) (car next)) (cdr next)) + (cons (list (car lst)) next))))))) + + +;; Collapses all the string in LST. +;; ("a" "b" (c d) "e" "f") -> ("ab" (c d) "ef") +(define (string-collapse lst) + (if (list? lst) + (let ((res (map (lambda (x) (if (string-list? x) + (apply string-append x) + x)) + (string-group (map string-collapse lst))))) + (if (single? res) (car res) res)) + lst)) + +;; If LST is an atom, return (list LST), else return LST. +(define (mklst lst) + (if (not (list? lst)) (list lst) lst)) + +;; Takes a list and "flattens" it, using the predicate TST to know when to stop +;; instead of terminating on atoms (see tutorial). +(define (context-flatten tst lst) + (if (or (not (list? lst)) (null? lst)) + lst + (if (tst lst) + (list lst) + (apply append + (map (lambda (x) (mklst (context-flatten tst x))) + lst))))) + +;; Takes a list and "flattens" it, using the list of keywords KEYWORD-LST to +;; know when to stop at (see tutorial). +(define (keyword-flatten keyword-lst lst) + (context-flatten + (lambda (x) + (if (or (not (list? x)) (null? x)) + #t + (member (car x) keyword-lst))) + lst))