Add file "rexp.scm" implementing list-based regular expressions.

diff --git a/v7/src/imail/compile.scm b/v7/src/imail/compile.scm
index 5371c130d7d106065007742d47265fa36ad59362..67eb3ef920412e479c2441a4114fe27375c4cbeb 100644 (file)
--- a/v7/src/imail/compile.scm
+++ b/v7/src/imail/compile.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: compile.scm,v 1.2 2000/04/12 03:54:04 cph Exp $
+;;; $Id: compile.scm,v 1.3 2000/04/13 15:35:58 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -31,6 +31,7 @@
                "imail-rmail"
                "imail-umail"
                "imail-util"
+               "rexp"
                "rfc822"
                "url"))
     (for-each (let ((syntax-table

diff --git a/v7/src/imail/ed-ffi.scm b/v7/src/imail/ed-ffi.scm
index 197c22b739f02ee1a112a7132d17350ec57ecf56..460ec18a1aa45e0b18c2efd3ddd8d41943777fa4 100644 (file)
--- a/v7/src/imail/ed-ffi.scm
+++ b/v7/src/imail/ed-ffi.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: ed-ffi.scm,v 1.2 2000/01/18 20:57:19 cph Exp $
+;;; $Id: ed-ffi.scm,v 1.3 2000/04/13 15:36:00 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -23,8 +23,11 @@
 (standard-scheme-find-file-initialization
  '#(("imail-core" (edwin imail) system-global-syntax-table)
     ("imail-file" (edwin imail) system-global-syntax-table)
+    ("imail-imap" (edwin imail) system-global-syntax-table)
     ("imail-rmail" (edwin imail) system-global-syntax-table)
     ("imail-top" (edwin imail) edwin-syntax-table)
     ("imail-umail" (edwin imail) system-global-syntax-table)
     ("imail-util" (edwin imail) system-global-syntax-table)
-    ("rfc822" (edwin imail) system-global-syntax-table)))
\ No newline at end of file
+    ("rexp" (runtime rexp) system-global-syntax-table)
+    ("rfc822" (edwin imail) system-global-syntax-table)
+    ("url" (runtime url) system-global-syntax-table)))
\ No newline at end of file

diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index 766070322cfd13c745024c1b9cc019ab387b49c3..0c567311fe8875e920cc860edd9932cdb3bc0734 100644 (file)
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.6 2000/04/12 03:53:59 cph Exp $
+;;; $Id: imail.pkg,v 1.7 2000/04/13 15:36:01 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -24,10 +24,36 @@
 (global-definitions "$bscm/sos/sos")
 (global-definitions "$bscm/edwin/edwinunx")
 
-(define-package (edwin url)
+(define-package (runtime rexp)
+  (files "rexp")
+  (parent ())
+  (export ()
+         rexp*
+         rexp+
+         rexp->regexp
+         rexp-alternatives
+         rexp-any-char
+         rexp-compile-pattern
+         rexp-group
+         rexp-line-end
+         rexp-line-start
+         rexp-not-syntax-char
+         rexp-not-word-char
+         rexp-not-word-edge
+         rexp-optional
+         rexp-string-end
+         rexp-string-start
+         rexp-syntax-char
+         rexp-word-char
+         rexp-word-edge
+         rexp-word-end
+         rexp-word-start
+         rexp?))
+
+(define-package (runtime url)
   (files "url")
-  (parent (edwin))
-  (export (edwin)
+  (parent ())
+  (export ()
          url:char-set:escaped
          url:char-set:extra
          url:char-set:national

diff --git a/v7/src/imail/rexp.scm b/v7/src/imail/rexp.scm
new file mode 100644 (file)
index 0000000..345ea7e
--- /dev/null
+++ b/v7/src/imail/rexp.scm
@@ -0,0 +1,188 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: rexp.scm,v 1.1 2000/04/13 15:36:02 cph Exp $
+;;;
+;;; Copyright (c) 2000 Massachusetts Institute of Technology
+;;;
+;;; This program 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 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program 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 this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;;; List-based Regular Expressions
+
+(declare (usual-integrations))
+\f
+(define (rexp? object)
+  (or (string? rexp)
+      (char? rexp)
+      (char-set? rexp)
+      (and (pair? rexp)
+          (list? (cdr rexp))
+          (let ((one-arg
+                 (lambda ()
+                   (and (fix:= 1 (length (cdr rexp)))
+                        (rexp? (cadr rexp))))))
+            (case (car rexp)
+              ((GROUP ALTERNATIVES)
+               (for-all? (cdr rexp) rexp?))
+              ((? * +)
+               (and (one-arg)
+                    (not (or (and (string? rexp)
+                                  (string-null? rexp))
+                             (and (pair? rexp)
+                                  (memq (car rexp)
+                                        nongroupable-rexp-types))))))
+              ((ANY-CHAR LINE-START LINE-END STRING-START STRING-END
+                         WORD-EDGE NOT-WORD-EDGE WORD-START WORD-END
+                         WORD-CHAR NOT-WORD-CHAR)
+               #t)
+              ((SYNTAX-CHAR NOT-SYNTAX-CHAR)
+               (and (one-arg)
+                    (assq (cadr rexp) syntax-type-alist)))
+              (else #f))))))
+
+(define (rexp-group . rexps) `(GROUP ,@rexps))
+(define (rexp-alternatives . rexps) `(ALTERNATIVES ,@rexps))
+(define (rexp-optional rexp) `(? ,rexp))
+(define (rexp* rexp) `(* ,rexp))
+(define (rexp+ rexp) `(+ ,rexp))
+
+(define (rexp-any-char) `(ANY-CHAR))
+(define (rexp-line-start) `(LINE-START))
+(define (rexp-line-end) `(LINE-END))
+(define (rexp-string-start) `(STRING-START))
+(define (rexp-string-end) `(STRING-END))
+(define (rexp-word-edge) `(WORD-EDGE))
+(define (rexp-not-word-edge) `(NOT-WORD-EDGE))
+(define (rexp-word-start) `(WORD-START))
+(define (rexp-word-end) `(WORD-END))
+(define (rexp-word-char) `(WORD-CHAR))
+(define (rexp-not-word-char) `(NOT-WORD-CHAR))
+(define (rexp-syntax-char type) `(SYNTAX-CHAR ,type))
+(define (rexp-not-syntax-char type) `(NOT-SYNTAX-CHAR ,type))
+\f
+(define (rexp-compile-pattern rexp case-fold?)
+  (re-compile-pattern (rexp->regexp rexp) case-fold?))
+
+(define (rexp->regexp rexp)
+  (let ((lose (lambda () (error "Malformed rexp:" rexp))))
+    (cond ((string? rexp)
+          (re-quote-string rexp))
+         ((char? rexp)
+          (re-quote-string (string rexp)))
+         ((char-set? rexp)
+          (char-set->regexp rexp))
+         ((and (pair? rexp) (list? (cdr rexp)))
+          (let ((alternatives
+                 (lambda ()
+                   (separated-append (map rexp->regexp (cdr rexp)) "\\|")))
+                (one-arg
+                 (lambda ()
+                   (if (not (fix:= 1 (length (cdr rexp))))
+                       (lose))
+                   (cadr rexp))))
+            (let ((repeat-arg
+                   (lambda ()
+                     (rexp->regexp (rexp-groupify (one-arg)))))
+                  (syntax-type
+                   (lambda ()
+                     (let ((entry (assq (one-arg) syntax-type-alist)))
+                       (if entry
+                           (cdr entry)
+                           (lose))))))
+              (case (car rexp)
+                ((GROUP) (string-append "\\(" (alternatives) "\\)"))
+                ((ALTERNATIVES) (alternatives))
+                ((?) (string-append (repeat-arg) "?"))
+                ((*) (string-append (repeat-arg) "*"))
+                ((+) (string-append (repeat-arg) "+"))
+                ((ANY-CHAR) ".")
+                ((LINE-START) "^")
+                ((LINE-END) "$")
+                ((STRING-START) "\\`")
+                ((STRING-END) "\\'")
+                ((WORD-EDGE) "\\b")
+                ((NOT-WORD-EDGE) "\\B")
+                ((WORD-START) "\\<")
+                ((WORD-END) "\\>")
+                ((WORD-CHAR) "\\w")
+                ((NOT-WORD-CHAR) "\\W")
+                ((SYNTAX-CHAR) (string-append "\\s" (syntax-type)))
+                ((NOT-SYNTAX-CHAR) (string-append "\\S" (syntax-type)))
+                (else (lose))))))
+         (else (lose)))))
+
+(define syntax-type-alist
+  '((WHITESPACE . " ")
+    (PUNCTUATION . ".")
+    (WORD . "w")
+    (SYMBOL . "_")
+    (OPEN . "(")
+    (CLOSE . ")")
+    (QUOTE . "\'")
+    (STRING-DELIMITER . "\"")
+    (MATH-DELIMITER . "$")
+    (ESCAPE . "\\")
+    (CHAR-QUOTE . "/")
+    (COMMENT-START . "<")
+    (COMMENT-END . ">")))
+\f
+(define (rexp-groupify rexp)
+  (let ((lose (lambda () (error "Malformed rexp:" rexp)))
+       (no-group (lambda () (error "Expression can't be grouped:" rexp))))
+    (cond ((string? rexp)
+          (case (string-length rexp)
+            ((0) (no-group))
+            ((1) rexp)
+            (else (rexp-group rexp))))
+         ((or (char? rexp) (char-set? rexp))
+          rexp)
+         ((pair? rexp)
+          (cond ((memq (car rexp) grouped-rexp-types) rexp)
+                ((memq (car rexp) groupable-rexp-types) (rexp-group rexp))
+                ((memq (car rexp) nongroupable-rexp-types) (no-group))
+                (else (lose))))
+         (else (lose)))))
+
+(define grouped-rexp-types
+  '(GROUP ANY-CHAR WORD-CHAR NOT-WORD-CHAR SYNTAX-CHAR NOT-SYNTAX-CHAR))
+
+(define groupable-rexp-types
+  '(ALTERNATIVES ? * +))
+
+(define nongroupable-rexp-types
+  '(LINE-START LINE-END STRING-START STRING-END WORD-EDGE NOT-WORD-EDGE
+              WORD-START WORD-END))
+
+(define (separated-append tokens separator)
+  (cond ((not (pair? tokens)) "")
+       ((not (pair? (cdr tokens))) (car tokens))
+       (else
+        (let ((string
+               (make-string
+                (let ((ns (string-length separator)))
+                  (do ((tokens (cdr tokens) (cdr tokens))
+                       (count (string-length (car tokens))
+                              (fix:+ count
+                                     (fix:+ (string-length (car tokens))
+                                            ns))))
+                      ((not (pair? tokens)) count))))))
+          (let loop
+              ((tokens (cdr tokens))
+               (index (string-move! (car tokens) string 0)))
+            (if (pair? tokens)
+                (loop (cdr tokens)
+                      (string-move! (car tokens)
+                                    string
+                                    (string-move! separator string index)))))
+          string))))
\ No newline at end of file

diff --git a/v7/src/runtime/rexp.scm b/v7/src/runtime/rexp.scm
new file mode 100644 (file)
index 0000000..345ea7e
--- /dev/null
+++ b/v7/src/runtime/rexp.scm
@@ -0,0 +1,188 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: rexp.scm,v 1.1 2000/04/13 15:36:02 cph Exp $
+;;;
+;;; Copyright (c) 2000 Massachusetts Institute of Technology
+;;;
+;;; This program 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 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program 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 this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;;; List-based Regular Expressions
+
+(declare (usual-integrations))
+\f
+(define (rexp? object)
+  (or (string? rexp)
+      (char? rexp)
+      (char-set? rexp)
+      (and (pair? rexp)
+          (list? (cdr rexp))
+          (let ((one-arg
+                 (lambda ()
+                   (and (fix:= 1 (length (cdr rexp)))
+                        (rexp? (cadr rexp))))))
+            (case (car rexp)
+              ((GROUP ALTERNATIVES)
+               (for-all? (cdr rexp) rexp?))
+              ((? * +)
+               (and (one-arg)
+                    (not (or (and (string? rexp)
+                                  (string-null? rexp))
+                             (and (pair? rexp)
+                                  (memq (car rexp)
+                                        nongroupable-rexp-types))))))
+              ((ANY-CHAR LINE-START LINE-END STRING-START STRING-END
+                         WORD-EDGE NOT-WORD-EDGE WORD-START WORD-END
+                         WORD-CHAR NOT-WORD-CHAR)
+               #t)
+              ((SYNTAX-CHAR NOT-SYNTAX-CHAR)
+               (and (one-arg)
+                    (assq (cadr rexp) syntax-type-alist)))
+              (else #f))))))
+
+(define (rexp-group . rexps) `(GROUP ,@rexps))
+(define (rexp-alternatives . rexps) `(ALTERNATIVES ,@rexps))
+(define (rexp-optional rexp) `(? ,rexp))
+(define (rexp* rexp) `(* ,rexp))
+(define (rexp+ rexp) `(+ ,rexp))
+
+(define (rexp-any-char) `(ANY-CHAR))
+(define (rexp-line-start) `(LINE-START))
+(define (rexp-line-end) `(LINE-END))
+(define (rexp-string-start) `(STRING-START))
+(define (rexp-string-end) `(STRING-END))
+(define (rexp-word-edge) `(WORD-EDGE))
+(define (rexp-not-word-edge) `(NOT-WORD-EDGE))
+(define (rexp-word-start) `(WORD-START))
+(define (rexp-word-end) `(WORD-END))
+(define (rexp-word-char) `(WORD-CHAR))
+(define (rexp-not-word-char) `(NOT-WORD-CHAR))
+(define (rexp-syntax-char type) `(SYNTAX-CHAR ,type))
+(define (rexp-not-syntax-char type) `(NOT-SYNTAX-CHAR ,type))
+\f
+(define (rexp-compile-pattern rexp case-fold?)
+  (re-compile-pattern (rexp->regexp rexp) case-fold?))
+
+(define (rexp->regexp rexp)
+  (let ((lose (lambda () (error "Malformed rexp:" rexp))))
+    (cond ((string? rexp)
+          (re-quote-string rexp))
+         ((char? rexp)
+          (re-quote-string (string rexp)))
+         ((char-set? rexp)
+          (char-set->regexp rexp))
+         ((and (pair? rexp) (list? (cdr rexp)))
+          (let ((alternatives
+                 (lambda ()
+                   (separated-append (map rexp->regexp (cdr rexp)) "\\|")))
+                (one-arg
+                 (lambda ()
+                   (if (not (fix:= 1 (length (cdr rexp))))
+                       (lose))
+                   (cadr rexp))))
+            (let ((repeat-arg
+                   (lambda ()
+                     (rexp->regexp (rexp-groupify (one-arg)))))
+                  (syntax-type
+                   (lambda ()
+                     (let ((entry (assq (one-arg) syntax-type-alist)))
+                       (if entry
+                           (cdr entry)
+                           (lose))))))
+              (case (car rexp)
+                ((GROUP) (string-append "\\(" (alternatives) "\\)"))
+                ((ALTERNATIVES) (alternatives))
+                ((?) (string-append (repeat-arg) "?"))
+                ((*) (string-append (repeat-arg) "*"))
+                ((+) (string-append (repeat-arg) "+"))
+                ((ANY-CHAR) ".")
+                ((LINE-START) "^")
+                ((LINE-END) "$")
+                ((STRING-START) "\\`")
+                ((STRING-END) "\\'")
+                ((WORD-EDGE) "\\b")
+                ((NOT-WORD-EDGE) "\\B")
+                ((WORD-START) "\\<")
+                ((WORD-END) "\\>")
+                ((WORD-CHAR) "\\w")
+                ((NOT-WORD-CHAR) "\\W")
+                ((SYNTAX-CHAR) (string-append "\\s" (syntax-type)))
+                ((NOT-SYNTAX-CHAR) (string-append "\\S" (syntax-type)))
+                (else (lose))))))
+         (else (lose)))))
+
+(define syntax-type-alist
+  '((WHITESPACE . " ")
+    (PUNCTUATION . ".")
+    (WORD . "w")
+    (SYMBOL . "_")
+    (OPEN . "(")
+    (CLOSE . ")")
+    (QUOTE . "\'")
+    (STRING-DELIMITER . "\"")
+    (MATH-DELIMITER . "$")
+    (ESCAPE . "\\")
+    (CHAR-QUOTE . "/")
+    (COMMENT-START . "<")
+    (COMMENT-END . ">")))
+\f
+(define (rexp-groupify rexp)
+  (let ((lose (lambda () (error "Malformed rexp:" rexp)))
+       (no-group (lambda () (error "Expression can't be grouped:" rexp))))
+    (cond ((string? rexp)
+          (case (string-length rexp)
+            ((0) (no-group))
+            ((1) rexp)
+            (else (rexp-group rexp))))
+         ((or (char? rexp) (char-set? rexp))
+          rexp)
+         ((pair? rexp)
+          (cond ((memq (car rexp) grouped-rexp-types) rexp)
+                ((memq (car rexp) groupable-rexp-types) (rexp-group rexp))
+                ((memq (car rexp) nongroupable-rexp-types) (no-group))
+                (else (lose))))
+         (else (lose)))))
+
+(define grouped-rexp-types
+  '(GROUP ANY-CHAR WORD-CHAR NOT-WORD-CHAR SYNTAX-CHAR NOT-SYNTAX-CHAR))
+
+(define groupable-rexp-types
+  '(ALTERNATIVES ? * +))
+
+(define nongroupable-rexp-types
+  '(LINE-START LINE-END STRING-START STRING-END WORD-EDGE NOT-WORD-EDGE
+              WORD-START WORD-END))
+
+(define (separated-append tokens separator)
+  (cond ((not (pair? tokens)) "")
+       ((not (pair? (cdr tokens))) (car tokens))
+       (else
+        (let ((string
+               (make-string
+                (let ((ns (string-length separator)))
+                  (do ((tokens (cdr tokens) (cdr tokens))
+                       (count (string-length (car tokens))
+                              (fix:+ count
+                                     (fix:+ (string-length (car tokens))
+                                            ns))))
+                      ((not (pair? tokens)) count))))))
+          (let loop
+              ((tokens (cdr tokens))
+               (index (string-move! (car tokens) string 0)))
+            (if (pair? tokens)
+                (loop (cdr tokens)
+                      (string-move! (car tokens)
+                                    string
+                                    (string-move! separator string index)))))
+          string))))
\ No newline at end of file