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 / runtime / regexp.scm < prev    next >
Text File  |  2000-04-12  |  7KB  |  200 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: regexp.scm,v 1.9 2000/04/13 03:01:38 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 1986, 1989-1999 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. ;;;; Regular Expressions
  22. ;;; package: (runtime regular-expression)
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define registers)
  27.  
  28. (define (initialize-package!)
  29.   (set! registers (make-vector 20 #f))
  30.   unspecific)
  31.  
  32. (define-structure (re-registers (type-descriptor re-registers-rtd))
  33.   (vector #f read-only #t))
  34.  
  35. (define (guarantee-re-registers object procedure)
  36.   (if (not (re-registers? object))
  37.       (error:wrong-type-argument object "regular-expression registers"
  38.                  procedure))
  39.   (re-registers-vector object))
  40.  
  41. (define (re-match-start-index i #!optional regs)
  42.   (guarantee-re-register i 'RE-MATCH-START-INDEX)
  43.   (vector-ref (if (or (default-object? regs) (not regs))
  44.           registers
  45.           (guarantee-re-registers regs 'RE-MATCH-START-INDEX))
  46.           i))
  47.  
  48. (define (re-match-end-index i #!optional regs)
  49.   (guarantee-re-register i 'RE-MATCH-END-INDEX)
  50.   (vector-ref (if (or (default-object? regs) (not regs))
  51.           registers
  52.           (guarantee-re-registers regs 'RE-MATCH-START-INDEX))
  53.           (fix:+ i 10)))
  54.  
  55. (define (guarantee-re-register i operator)
  56.   (if (not (and (exact-nonnegative-integer? i) (< i 10)))
  57.       (error:wrong-type-argument i "regular-expression register" operator)))
  58.  
  59. (define (re-registers)
  60.   (make-re-registers (vector-copy registers)))
  61.  
  62. (define (set-re-registers! regs)
  63.   (let ((regs (guarantee-re-registers regs 'SET-RE-REGISTERS!)))
  64.     (do ((i 0 (fix:+ i 1)))
  65.     ((fix:= 20 i))
  66.       (vector-set! registers i (vector-ref regs i)))))
  67.  
  68. (define (preserving-re-registers thunk)
  69.   (let ((registers* unspecific))
  70.     (dynamic-wind (lambda () (set! registers* (re-registers)) unspecific)
  71.           thunk
  72.           (lambda () (set-re-registers! registers*)))))
  73.  
  74. (define (re-match-extract string regs i)
  75.   (substring string
  76.          (re-match-start-index i regs)
  77.          (re-match-end-index i regs)))
  78.  
  79. (define (make-substring-operation name primitive)
  80.   (lambda (regexp string start end #!optional case-fold? syntax-table)
  81.     (let ((regexp
  82.        (if (compiled-regexp? regexp)
  83.            regexp
  84.            (re-compile-pattern regexp
  85.                    (if (default-object? case-fold?)
  86.                        #f
  87.                        case-fold?))))
  88.       (regs (make-vector 20 #f)))
  89.       (and (primitive (compiled-regexp/byte-stream regexp)
  90.               (compiled-regexp/translation-table regexp)
  91.               (char-syntax-table/entries
  92.                (if (or (default-object? syntax-table)
  93.                    (not syntax-table))
  94.                standard-char-syntax-table
  95.                syntax-table))
  96.               regs string start end)
  97.        (make-re-registers regs)))))
  98.  
  99. (define re-substring-match
  100.   (make-substring-operation 'RE-SUBSTRING-MATCH
  101.                 (ucode-primitive re-match-substring)))
  102.  
  103. (define re-substring-search-forward
  104.   (make-substring-operation 'RE-SUBSTRING-SEARCH-FORWARD
  105.                 (ucode-primitive re-search-substring-forward)))
  106.  
  107. (define re-substring-search-backward
  108.   (make-substring-operation 'RE-SUBSTRING-SEARCH-BACKWARD
  109.                 (ucode-primitive re-search-substring-backward)))
  110.  
  111. (define (make-string-operation substring-operation)
  112.   (lambda (regexp string #!optional case-fold? syntax-table)
  113.     (substring-operation regexp string 0 (string-length string)
  114.              (if (default-object? case-fold?) #f case-fold?)
  115.              (if (default-object? syntax-table) #f syntax-table))))
  116.  
  117. (define re-string-match
  118.   (make-string-operation re-substring-match))
  119.  
  120. (define re-string-search-forward
  121.   (make-string-operation re-substring-search-forward))
  122.  
  123. (define re-string-search-backward
  124.   (make-string-operation re-substring-search-backward))
  125.  
  126. (define (regexp-group . alternatives)
  127.   (let ((alternatives
  128.      (list-transform-positive alternatives identity-procedure)))
  129.     (if (null? alternatives)
  130.     "\\(\\)"
  131.     (apply string-append
  132.            (cons "\\("
  133.              (let loop ((alternatives alternatives))
  134.                (cons (car alternatives)
  135.                  (if (null? (cdr alternatives))
  136.                  (list "\\)")
  137.                  (cons "\\|" (loop (cdr alternatives)))))))))))
  138.  
  139. (define (char-set->regexp char-set)
  140.   (let ((chars (char-set-members char-set)))
  141.     (cond ((null? chars)
  142.        "")
  143.       ((and (memv (car chars) '(#\^ #\- #\]))
  144.         (null? (cdr chars)))
  145.        (string #\\ (car chars)))
  146.       (else
  147.        (let ((ranges
  148.           (let outer ((chars chars) (ranges '()))
  149.             (if (pair? chars)
  150.             (let ((start (car chars)))
  151.               (let inner ((chars (cdr chars)) (end (car chars)))
  152.                 (if (and (pair? chars)
  153.                      (fix:= (fix:+ (char->integer end) 1)
  154.                         (char->integer (car chars))))
  155.                 (inner (cdr chars) (car chars))
  156.                 (outer
  157.                  chars
  158.                  (let ((accum
  159.                     (lambda (start end ranges)
  160.                       (cons (if (and (char=? start end)
  161.                              (not (char=? #\-
  162.                                       start)))
  163.                             start
  164.                             (cons start end))
  165.                         ranges))))
  166.                    (if (and (not (char=? start end))
  167.                         (or (char=? #\] start)
  168.                         (char=? #\] end)))
  169.                        (if (char=? #\] start)
  170.                        (cons #\] (accum #\^ end ranges))
  171.                        (accum start #\\ (cons #\] ranges)))
  172.                        (accum start end ranges)))))))
  173.             (reverse! ranges)))))
  174.          (let ((ranges
  175.             (if (memv #\] ranges)
  176.             (cons #\] (delv! #\] ranges))
  177.             ranges)))
  178.            (let ((n
  179.               (let loop ((ranges ranges) (n 2))
  180.             (if (pair? ranges)
  181.                 (loop (cdr ranges)
  182.                   (fix:+ n (if (pair? (car ranges)) 3 1)))
  183.                 n))))
  184.          (let ((s (make-string n)))
  185.            (string-set! s 0 #\[)
  186.            (let loop ((ranges ranges) (i 1))
  187.              (if (pair? ranges)
  188.              (loop (cdr ranges)
  189.                    (let ((range (car ranges)))
  190.                  (if (pair? range)
  191.                      (begin
  192.                        (string-set! s i (car range))
  193.                        (string-set! s (fix:+ i 1) #\-)
  194.                        (string-set! s (fix:+ i 2) (cdr range))
  195.                        (fix:+ i 3))
  196.                      (begin
  197.                        (string-set! s i range)
  198.                        (fix:+ i 1)))))
  199.              (string-set! s i #\])))
  200.            s))))))))