101 lines
3.3 KiB
Scheme
101 lines
3.3 KiB
Scheme
;;; GNU Mes --- Maxwell Equations of Software
|
|
;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
|
|
;;;
|
|
;;; This file is part of GNU Mes.
|
|
;;;
|
|
;;; GNU Mes is free software; you can redistribute it and/or modify it
|
|
;;; under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
;;; your option) any later version.
|
|
;;;
|
|
;;; GNU Mes 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 General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Taken from GNU Guile
|
|
|
|
;;; simplify-tree.scm --- utility functions for the PEG parser
|
|
|
|
(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))
|