home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / imail / rexp.scm < prev    next >
Text File  |  2000-07-07  |  7KB  |  217 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: rexp.scm,v 1.15 2000/07/08 00:41:45 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 2000 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; This program is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU General Public License as
  9. ;;; published by the Free Software Foundation; either version 2 of the
  10. ;;; License, or (at your option) any later version.
  11. ;;;
  12. ;;; This program is distributed in the hope that it will be useful,
  13. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;;; General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with this program; if not, write to the Free Software
  19. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. ;;;; List-based Regular Expressions
  22.  
  23. (declare (usual-integrations))
  24.  
  25. (define (rexp? rexp)
  26.   (or (char-set? rexp)
  27.       (string? rexp)
  28.       (and (pair? rexp)
  29.        (list? (cdr rexp))
  30.        (let ((one-arg
  31.           (lambda ()
  32.             (and (fix:= 1 (length (cdr rexp)))
  33.              (rexp? (cadr rexp))))))
  34.          (case (car rexp)
  35.            ((ALTERNATIVES SEQUENCE)
  36.         (for-all? (cdr rexp) rexp?))
  37.            ((GROUP OPTIONAL * +)
  38.         (and (one-arg)
  39.              (not (or (and (string? rexp)
  40.                    (string-null? rexp))
  41.                   (and (pair? rexp)
  42.                    (memq (car rexp) boundary-rexp-types))))))
  43.            ((CASE-FOLD)
  44.         (and (fix:= 1 (length (cdr rexp)))
  45.              (string? (cadr exp))))
  46.            ((ANY-CHAR LINE-START LINE-END STRING-START STRING-END
  47.               WORD-EDGE NOT-WORD-EDGE WORD-START WORD-END
  48.               WORD-CHAR NOT-WORD-CHAR)
  49.         (null? (cdr rexp)))
  50.            ((SYNTAX-CHAR NOT-SYNTAX-CHAR)
  51.         (and (one-arg)
  52.              (assq (cadr rexp) syntax-type-alist)))
  53.            (else #f))))))
  54.  
  55. (define boundary-rexp-types
  56.   '(LINE-START LINE-END STRING-START STRING-END WORD-EDGE NOT-WORD-EDGE
  57.            WORD-START WORD-END))
  58.  
  59. (define syntax-type-alist
  60.   '((WHITESPACE . " ")
  61.     (PUNCTUATION . ".")
  62.     (WORD . "w")
  63.     (SYMBOL . "_")
  64.     (OPEN . "(")
  65.     (CLOSE . ")")
  66.     (QUOTE . "\'")
  67.     (STRING-DELIMITER . "\"")
  68.     (MATH-DELIMITER . "$")
  69.     (ESCAPE . "\\")
  70.     (CHAR-QUOTE . "/")
  71.     (COMMENT-START . "<")
  72.     (COMMENT-END . ">")))
  73.  
  74. (define (rexp-alternatives . rexps)
  75.   `(ALTERNATIVES ,@rexps))
  76.  
  77. (define (rexp-sequence . rexps)
  78.   (let ((rexps (simplify-sequence-args rexps)))
  79.     (if (pair? rexps)
  80.     (if (pair? (cdr rexps))
  81.         `(SEQUENCE ,@rexps)
  82.         (car rexps))
  83.     "")))
  84.  
  85. (define (simplify-sequence-args rexps)
  86.   (append-map (lambda (rexp)
  87.         (cond ((and (string? rexp) (string-null? rexp))
  88.                '())
  89.               ((and (pair? rexp) (eq? 'SEQUENCE (car rexp)))
  90.                (cdr rexp))
  91.               ((and (pair? rexp) (eq? 'ALTERNATIVES (car rexp)))
  92.                (list `(GROUP ,rexp)))
  93.               (else
  94.                (list rexp))))
  95.           rexps))
  96.  
  97. (define (rexp-group . rexps)
  98.   `(GROUP ,(apply rexp-sequence rexps)))
  99.  
  100. (define (rexp-optional . rexps)
  101.   `(OPTIONAL ,(rexp-groupify (apply rexp-sequence rexps))))
  102.  
  103. (define (rexp* . rexps)
  104.   `(* ,(rexp-groupify (apply rexp-sequence rexps))))
  105.  
  106. (define (rexp+ . rexps)
  107.   `(+ ,(rexp-groupify (apply rexp-sequence rexps))))
  108.  
  109. (define (rexp-groupify rexp)
  110.   (let ((group (lambda () `(GROUP ,rexp)))
  111.     (no-group (lambda () (error "Expression can't be grouped:" rexp))))
  112.     (cond ((and (string? rexp) (not (char-set? rexp)))
  113.        (case (string-length rexp)
  114.          ((0) (no-group))
  115.          ((1) rexp)
  116.          (else (group))))
  117.       ((pair? rexp)
  118.        (cond ((memq (car rexp) boundary-rexp-types)
  119.           (no-group))
  120.          ((memq (car rexp) '(ALTERNATIVES SEQUENCE OPTIONAL * +))
  121.           (group))
  122.          (else rexp)))
  123.       (else rexp))))
  124.  
  125. (define (rexp-any-char) `(ANY-CHAR))
  126. (define (rexp-line-start) `(LINE-START))
  127. (define (rexp-line-end) `(LINE-END))
  128. (define (rexp-string-start) `(STRING-START))
  129. (define (rexp-string-end) `(STRING-END))
  130. (define (rexp-word-edge) `(WORD-EDGE))
  131. (define (rexp-not-word-edge) `(NOT-WORD-EDGE))
  132. (define (rexp-word-start) `(WORD-START))
  133. (define (rexp-word-end) `(WORD-END))
  134. (define (rexp-word-char) `(WORD-CHAR))
  135. (define (rexp-not-word-char) `(NOT-WORD-CHAR))
  136. (define (rexp-syntax-char type) `(SYNTAX-CHAR ,type))
  137. (define (rexp-not-syntax-char type) `(NOT-SYNTAX-CHAR ,type))
  138.  
  139. (define (rexp-case-fold rexp)
  140.   (cond ((and (string? rexp) (not (char-set? rexp)))
  141.      `(CASE-FOLD ,rexp))
  142.     ((and (pair? rexp)
  143.           (memq (car rexp) '(ALTERNATIVES SEQUENCE GROUP OPTIONAL * +))
  144.           (list? (cdr rexp)))
  145.      (cons (car rexp)
  146.            (map rexp-case-fold (cdr rexp))))
  147.     (else rexp)))
  148.  
  149. (define (rexp-compile rexp)
  150.   (re-compile-pattern (rexp->regexp rexp) #f))
  151.  
  152. (define (rexp->regexp rexp)
  153.   (let ((lose (lambda () (error "Malformed rexp:" rexp))))
  154.     (cond ((char-set? rexp)
  155.        (char-set->regexp rexp))
  156.       ((string? rexp)
  157.        (re-quote-string rexp))
  158.       ((and (pair? rexp) (list? (cdr rexp)))
  159.        (let ((one-arg
  160.           (lambda ()
  161.             (if (fix:= 1 (length (cdr rexp)))
  162.             (cadr rexp)
  163.             (lose))))
  164.          (rexp-args (lambda () (map rexp->regexp (cdr rexp)))))
  165.          (let ((rexp-arg (lambda () (rexp->regexp (one-arg))))
  166.            (syntax-type
  167.             (lambda ()
  168.               (let ((entry (assq (one-arg) syntax-type-alist)))
  169.             (if entry
  170.                 (cdr entry)
  171.                 (lose))))))
  172.            (case (car rexp)
  173.          ((ALTERNATIVES)
  174.           (decorated-string-append "" "\\|" "" (rexp-args)))
  175.          ((SEQUENCE) (apply string-append (rexp-args)))
  176.          ((GROUP) (string-append "\\(" (rexp-arg) "\\)"))
  177.          ((OPTIONAL) (string-append (rexp-arg) "?"))
  178.          ((*) (string-append (rexp-arg) "*"))
  179.          ((+) (string-append (rexp-arg) "+"))
  180.          ((CASE-FOLD)
  181.           (let ((arg (one-arg)))
  182.             (if (and (string? arg) (not (char-set? arg)))
  183.             (case-fold-string arg)
  184.             (lose))))
  185.          ((ANY-CHAR) ".")
  186.          ((LINE-START) "^")
  187.          ((LINE-END) "$")
  188.          ((STRING-START) "\\`")
  189.          ((STRING-END) "\\'")
  190.          ((WORD-EDGE) "\\b")
  191.          ((NOT-WORD-EDGE) "\\B")
  192.          ((WORD-START) "\\<")
  193.          ((WORD-END) "\\>")
  194.          ((WORD-CHAR) "\\w")
  195.          ((NOT-WORD-CHAR) "\\W")
  196.          ((SYNTAX-CHAR) (string-append "\\s" (syntax-type)))
  197.          ((NOT-SYNTAX-CHAR) (string-append "\\S" (syntax-type)))
  198.          (else (lose))))))
  199.       (else (lose)))))
  200.  
  201. (define (case-fold-string s)
  202.   (let ((end (string-length s)))
  203.     (let loop ((start 0) (parts '()))
  204.       (let ((index
  205.          (substring-find-next-char-in-set s start end
  206.                           char-set:alphabetic)))
  207.     (if index
  208.         (loop (fix:+ index 1)
  209.           (cons* (let ((char (string-ref s index)))
  210.                (string-append "["
  211.                       (string (char-upcase char))
  212.                       (string (char-downcase char))
  213.                       "]"))
  214.              (re-quote-string
  215.               (substring s start index))
  216.              parts))
  217.         (apply string-append (reverse! parts)))))))