From cc5ae53af411ec47b6d2b05ee8747e3f94490d0a Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 4 Mar 1997 06:43:51 +0000 Subject: [PATCH] Create new data type for a compiled regular expression; this type contains the case-fold information used to compile the regexp. Modify the low-level regular-expression procedures to accept this new type and to no longer have an argument for case-fold. Modify the high-level regular-expression procedures to accept a compiled regular expression in place of a regular-expression string; in this case the optional case-fold argument is ignored. Edit all references to the low-level procedures to conform to this new design. --- v7/src/edwin/comhst.scm | 12 ++-- v7/src/edwin/comint.scm | 10 +-- v7/src/edwin/debug.scm | 7 +- v7/src/edwin/dired.scm | 11 ++-- v7/src/edwin/dosfile.scm | 26 ++------ v7/src/edwin/edwin.pkg | 6 +- v7/src/edwin/fileio.scm | 6 +- v7/src/edwin/info.scm | 8 +-- v7/src/edwin/malias.scm | 12 ++-- v7/src/edwin/manual.scm | 13 ++-- v7/src/edwin/occur.scm | 132 ++++++++++++++++---------------------- v7/src/edwin/regexp.scm | 89 +++++++++++++------------ v7/src/edwin/rmail.scm | 17 ++--- v7/src/edwin/rmailsrt.scm | 125 ++++++++++++++++-------------------- v7/src/edwin/rmailsum.scm | 15 ++--- v7/src/edwin/shell.scm | 21 +++--- v7/src/edwin/snr.scm | 15 +---- v7/src/edwin/strtab.scm | 24 +++---- v7/src/edwin/telnet.scm | 10 +-- v7/src/edwin/unix.scm | 12 ++-- v7/src/edwin/verilog.scm | 17 ++--- v7/src/runtime/rgxcmp.scm | 25 ++++++-- 22 files changed, 265 insertions(+), 348 deletions(-) diff --git a/v7/src/edwin/comhst.scm b/v7/src/edwin/comhst.scm index 53d374ec8..3b75d7095 100644 --- a/v7/src/edwin/comhst.scm +++ b/v7/src/edwin/comhst.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: comhst.scm,v 1.4 1994/04/23 04:53:27 cph Exp $ +$Id: comhst.scm,v 1.5 1997/03/04 06:42:53 cph Exp $ -Copyright (c) 1992-94 Massachusetts Institute of Technology +Copyright (c) 1992-97 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -133,10 +133,10 @@ license should have been included along with this file. |# (set-command-message! comint-input-ring-tag start left right) (editor-failure "Not found")) - ((re-search-string-forward pattern - false - syntax-table - (ring-ref ring (- index 1))) + ((re-string-search pattern + (ring-ref ring (- index 1)) + #f + syntax-table) (set-variable! comint-last-input-match string) ((ref-command comint-previous-input) (- index start))) (else diff --git a/v7/src/edwin/comint.scm b/v7/src/edwin/comint.scm index e1b0498ae..145dfc1b8 100644 --- a/v7/src/edwin/comint.scm +++ b/v7/src/edwin/comint.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: comint.scm,v 1.22 1996/04/23 22:12:11 cph Exp $ +$Id: comint.scm,v 1.23 1997/03/04 06:42:55 cph Exp $ -Copyright (c) 1991-96 Massachusetts Institute of Technology +Copyright (c) 1991-97 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -219,8 +219,10 @@ Thus it can, for instance, track cd/pushd/popd commands issued to the shell." Only inputs answering true to this procedure are saved on the input history list. Default is to save anything that isn't all whitespace." (lambda (string) - (not (re-match-string-forward (re-compile-pattern "\\`\\s *\\'" false) - false (ref-variable syntax-table) string)))) + (not (re-string-match "\\`\\s *\\'" + string + #f + (ref-variable syntax-table))))) (define-command send-invisible "Read a string without echoing, and send it to the process running diff --git a/v7/src/edwin/debug.scm b/v7/src/edwin/debug.scm index ea2b96140..7308533b5 100644 --- a/v7/src/edwin/debug.scm +++ b/v7/src/edwin/debug.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: debug.scm,v 1.40 1997/02/23 06:24:31 cph Exp $ +;;; $Id: debug.scm,v 1.41 1997/03/04 06:42:58 cph Exp $ ;;; ;;; Copyright (c) 1992-97 Massachusetts Institute of Technology ;;; @@ -1044,10 +1044,7 @@ The buffer below describes the current subproblem or reduction. (define (geometry? geometry) (let ((geometry-pattern "[0-9]+x[0-9]+\\(-[0-9]+\\|+[0-9]+\\|\\)\\(-[0-9]+\\|+[0-9]+\\|\\)")) - (re-match-string-forward (re-compile-pattern geometry-pattern #f) - #f - #f - geometry))) + (re-string-match (re-compile-pattern geometry-pattern #f) geometry))) (define default-screen-geometry #f) diff --git a/v7/src/edwin/dired.scm b/v7/src/edwin/dired.scm index 65ccde6b4..08de6e91f 100644 --- a/v7/src/edwin/dired.scm +++ b/v7/src/edwin/dired.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dired.scm,v 1.165 1996/10/02 17:00:10 cph Exp $ +;;; $Id: dired.scm,v 1.166 1997/03/04 06:43:01 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-96 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-97 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -294,11 +294,8 @@ Type `h' after entering dired for more info." (let ((filename (dired-filename-string lstart))) (if (and filename (or (not (string? dired-trivial-filenames)) - (not (re-match-string-forward - (re-compile-pattern dired-trivial-filenames #f) - #f - syntax-table - filename)))) + (not (re-string-match dired-trivial-filenames + filename #f syntax-table)))) lstart (let ((lstart (line-start lstart 1 #f))) (and lstart diff --git a/v7/src/edwin/dosfile.scm b/v7/src/edwin/dosfile.scm index 6e19b0d80..fce1f4d91 100644 --- a/v7/src/edwin/dosfile.scm +++ b/v7/src/edwin/dosfile.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dosfile.scm,v 1.8 1996/10/09 15:44:37 cph Exp $ +;;; $Id: dosfile.scm,v 1.9 1997/03/04 06:43:04 cph Exp $ ;;; -;;; Copyright (c) 1994-96 Massachusetts Institute of Technology +;;; Copyright (c) 1994-97 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -94,9 +94,8 @@ Includes the new backup. Must be > 0." (and (fix:> index 0) (or (char=? (string-ref prefix (fix:- index 1)) #\/) (char=? (string-ref prefix (fix:- index 1)) #\\)))) - (re-match-substring-forward - (re-compile-pattern "[\\/$~]\\|[a-zA-Z]:" #t) - #t #f string index (string-length string))) + (re-substring-match "[\\/$~]\\|[a-zA-Z]:" + string index (string-length string))) (string-tail string index) string))) @@ -227,18 +226,10 @@ Includes the new backup. Must be > 0." (let ((type (pathname-type filename))) (and (string? type) (or (string-ci=? "bak" type) - (re-match-string-forward (re-compile-pattern ".[0-9][0-9]" #f) - #f - #f - type)))))) + (re-string-match ".[0-9][0-9]" type)))))) (define (os/numeric-backup-filename? filename) - (and (let ((try - (lambda (pattern) - (re-search-string-forward (re-compile-pattern pattern #f) - #f - #f - filename)))) + (and (let ((try (lambda (pattern) (re-string-search pattern filename)))) (or (try "^\\([^.]+\\)\\.\\([0-9][0-9][0-9]\\)$") (try "^\\([^.]+\\.[^.]\\)\\([0-9][0-9]\\)$") (there-exists? dos/backup-suffixes @@ -257,10 +248,7 @@ Includes the new backup. Must be > 0." version)))))) (define (os/auto-save-filename? filename) - (or (re-match-string-forward (re-compile-pattern "^#.+#$" #f) - #f - #f - (file-namestring filename)) + (or (re-string-match "^#.+#$" (file-namestring filename)) (let ((type (pathname-type filename))) (and (string? type) (string-ci=? "sav" type))))) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 8549998c5..3fac5053d 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.205 1997/03/03 23:03:05 cph Exp $ +$Id: edwin.pkg,v 1.206 1997/03/04 06:43:07 cph Exp $ Copyright (c) 1989-97 Massachusetts Institute of Technology @@ -572,6 +572,10 @@ MIT in each case. |# (files "rgxcmp") (parent (edwin)) (export (edwin) + compiled-regexp? + compiled-regexp/byte-stream + compiled-regexp/case-fold? + compiled-regexp/translation-table condition-type:re-compile-pattern re-compile-char re-compile-char-set diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm index 600690f4c..52cd3ea39 100644 --- a/v7/src/edwin/fileio.scm +++ b/v7/src/edwin/fileio.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: fileio.scm,v 1.141 1997/01/03 04:40:03 cph Exp $ +;;; $Id: fileio.scm,v 1.142 1997/03/04 06:43:11 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-96 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-97 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -260,7 +260,7 @@ of the predicates is satisfied, the file is written in the usual way." (or (let ((filename (->namestring pathname))) (let loop ((types (ref-variable auto-mode-alist buffer))) (and (not (null? types)) - (if (re-match-string-forward (caar types) false false filename) + (if (re-string-match (caar types) filename) (->mode (cdar types)) (loop (cdr types)))))) (let ((type (os/pathname-type-for-mode pathname))) diff --git a/v7/src/edwin/info.scm b/v7/src/edwin/info.scm index 01c61a15b..1ae26e87d 100644 --- a/v7/src/edwin/info.scm +++ b/v7/src/edwin/info.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: info.scm,v 1.122 1997/02/23 06:24:38 cph Exp $ +;;; $Id: info.scm,v 1.123 1997/03/04 06:43:14 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-97 Massachusetts Institute of Technology ;;; @@ -511,8 +511,7 @@ except for \\[info-cease-edit] to return to Info." (group (mark-group mark))) (let ((end (group-end-index group))) (let loop ((start (mark-index mark))) - (if (re-search-buffer-forward pattern false false - group start end) + (if (re-search-buffer-forward pattern #f group start end) (let ((item (re-match-start-index 1))) (let ((keyword (group-extract-string group @@ -527,8 +526,7 @@ except for \\[info-cease-edit] to return to Info." (group (mark-group mark))) (let ((end (group-end-index group))) (let loop ((start (mark-index mark))) - (if (re-search-buffer-forward pattern false false - group start end) + (if (re-search-buffer-forward pattern #f group start end) (let ((item (re-match-start-index 1))) (marker group item diff --git a/v7/src/edwin/malias.scm b/v7/src/edwin/malias.scm index 5e3794c57..d890c3ac1 100644 --- a/v7/src/edwin/malias.scm +++ b/v7/src/edwin/malias.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/malias.scm,v 1.2 1991/05/04 20:14:43 cph Exp $ +;;; $Id: malias.scm,v 1.3 1997/03/04 06:43:17 cph Exp $ ;;; -;;; Copyright (c) 1991 Massachusetts Institute of Technology +;;; Copyright (c) 1991-97 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -145,12 +145,8 @@ (let ((line (read-mailrc-line port))) (if line (let ((index - (re-match-string-forward - (re-compile-pattern "^\\(a\\|alias\\|g\\|group\\)[ \t]+" - false) - false - false - line))) + (re-string-match "^\\(a\\|alias\\|g\\|group\\)[ \t]+" + line))) (if index (let ((parsed-line (parse-mailrc-line line index))) (if (null? (cdr parsed-line)) diff --git a/v7/src/edwin/manual.scm b/v7/src/edwin/manual.scm index bafe50771..a21902935 100644 --- a/v7/src/edwin/manual.scm +++ b/v7/src/edwin/manual.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: manual.scm,v 1.12 1996/04/23 22:24:05 cph Exp $ +;;; $Id: manual.scm,v 1.13 1997/03/04 06:43:19 cph Exp $ ;;; -;;; Copyright (c) 1991-96 Massachusetts Institute of Technology +;;; Copyright (c) 1991-97 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -53,12 +53,8 @@ where SECTION is the desired section of the manual, as in `tty(4)'." "sManual entry (topic): " (lambda (topic #!optional section) (if (and (default-object? section) - (re-match-string-forward - (re-compile-pattern - "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" - false) - true - false + (re-string-match + "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" topic)) (begin (set! section @@ -189,7 +185,6 @@ where SECTION is the desired section of the manual, as in `tty(4)'." (let ((syntax-table (group-syntax-table group))) (let loop ((index (group-start-index group))) (if (re-search-buffer-forward pattern - case-fold-search syntax-table group index diff --git a/v7/src/edwin/occur.scm b/v7/src/edwin/occur.scm index 67efe2340..b18771026 100644 --- a/v7/src/edwin/occur.scm +++ b/v7/src/edwin/occur.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: occur.scm,v 1.2 1995/05/19 18:55:50 cph Exp $ +;;; $Id: occur.scm,v 1.3 1997/03/04 06:43:21 cph Exp $ ;;; -;;; Copyright (c) 1992-95 Massachusetts Institute of Technology +;;; Copyright (c) 1992-97 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -61,41 +61,36 @@ Applies to all lines after point." (command-procedure (ref-command-object keep-lines))) (define (keep-lines start end regexp) - (let ((case-fold-search (ref-variable case-fold-search start)) + (let ((pattern + (re-compile-pattern regexp (ref-variable case-fold-search start))) (syntax-table (ref-variable syntax-table start)) (group (mark-group start)) (start (mark-index start)) (anchor (mark-left-inserting-copy start)) (end (mark-left-inserting-copy end))) - (let ((pattern (re-compile-pattern regexp case-fold-search))) - (letrec - ((loop - (lambda (start point) - (let ((point - (re-search-buffer-forward pattern - case-fold-search - syntax-table - group - point - (mark-index end)))) - (if point - (begin - (set-mark-index! anchor point) - (let ((end - (line-start-index group - (re-match-start-index 0)))) - (if (< start end) - (group-delete! group start end))) - (continue (mark-index anchor))) - (group-delete! group start (mark-index end)))))) - (continue - (lambda (point) - (let ((start (line-end-index group point))) - (if (< start (mark-index end)) - (loop (+ start 1) point)))))) - (if (line-start-index? group start) - (loop start start) - (continue start)))) + (letrec + ((loop + (lambda (start point) + (let ((point + (re-search-buffer-forward pattern syntax-table + group point (mark-index end)))) + (if point + (begin + (set-mark-index! anchor point) + (let ((end + (line-start-index group (re-match-start-index 0)))) + (if (< start end) + (group-delete! group start end))) + (continue (mark-index anchor))) + (group-delete! group start (mark-index end)))))) + (continue + (lambda (point) + (let ((start (line-end-index group point))) + (if (< start (mark-index end)) + (loop (+ start 1) point)))))) + (if (line-start-index? group start) + (loop start start) + (continue start))) (mark-temporary! anchor) (mark-temporary! end))) @@ -114,24 +109,23 @@ Applies to lines after point." (command-procedure (ref-command-object flush-lines))) (define (flush-lines start end regexp) - (let ((case-fold-search (ref-variable case-fold-search start)) + (let ((pattern + (re-compile-pattern regexp (ref-variable case-fold-search start))) (syntax-table (ref-variable syntax-table start)) (group (mark-group start)) (start (mark-left-inserting-copy start)) (end (mark-left-inserting-copy end))) - (let ((pattern (re-compile-pattern regexp case-fold-search))) - (do () - ((not (re-search-buffer-forward pattern - case-fold-search - syntax-table - group - (mark-index start) - (mark-index end)))) - (let ((point (line-end-index group (re-match-end-index 0)))) - (set-mark-index! start point) - (group-delete! group - (line-start-index group (re-match-start-index 0)) - (if (< point (mark-index end)) (+ point 1) point))))) + (do () + ((not (re-search-buffer-forward pattern + syntax-table + group + (mark-index start) + (mark-index end)))) + (let ((point (line-end-index group (re-match-end-index 0)))) + (set-mark-index! start point) + (group-delete! group + (line-start-index group (re-match-start-index 0)) + (if (< point (mark-index end)) (+ point 1) point)))) (mark-temporary! start) (mark-temporary! end))) @@ -149,22 +143,17 @@ Applies to lines after point." (command-procedure (ref-command-object count-matches))) (define (count-matches start end regexp) - (let ((case-fold-search (ref-variable case-fold-search start)) + (let ((pattern + (re-compile-pattern regexp (ref-variable case-fold-search start))) (syntax-table (ref-variable syntax-table start)) (group (mark-group start)) (end (mark-index end))) - (let ((pattern (re-compile-pattern regexp case-fold-search))) - (let loop ((start (mark-index start)) (result 0)) - (let ((match - (re-search-buffer-forward pattern - case-fold-search - syntax-table - group - start - end))) - (if match - (loop match (+ result 1)) - result)))))) + (let loop ((start (mark-index start)) (result 0)) + (let ((match + (re-search-buffer-forward pattern syntax-table group start end))) + (if match + (loop match (+ result 1)) + result))))) (define-major-mode occur fundamental "Occur" "Major mode for output from \\[occur]. @@ -246,25 +235,18 @@ It serves as a menu to find any of the occurrences in this buffer. (command-procedure (ref-command-object occur))) (define (re-occurrences start end regexp) - (let ((case-fold-search (ref-variable case-fold-search start)) + (let ((pattern + (re-compile-pattern regexp (ref-variable case-fold-search start))) (syntax-table (ref-variable syntax-table start)) (group (mark-group start)) (end (mark-index end))) - (let ((pattern (re-compile-pattern regexp case-fold-search))) - (let loop ((start (mark-index start))) - (let ((match - (re-search-buffer-forward pattern - case-fold-search - syntax-table - group - start - end))) - (if match - (cons (make-temporary-mark group - (line-start-index group match) - false) - (loop (line-end-index group match))) - '())))))) + (let loop ((start (mark-index start))) + (let ((match + (re-search-buffer-forward pattern syntax-table group start end))) + (if match + (cons (make-temporary-mark group (line-start-index group match) #f) + (loop (line-end-index group match))) + '()))))) (define (format-occurrences occurrences nlines output) (if (null? occurrences) diff --git a/v7/src/edwin/regexp.scm b/v7/src/edwin/regexp.scm index c24e2bd05..8cd82072d 100644 --- a/v7/src/edwin/regexp.scm +++ b/v7/src/edwin/regexp.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: regexp.scm,v 1.68 1997/03/03 23:04:13 cph Exp $ +;;; $Id: regexp.scm,v 1.69 1997/03/04 06:43:23 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-97 Massachusetts Institute of Technology ;;; @@ -183,34 +183,31 @@ (group-delete! group start (re-match-end-index 0)) (make-mark group start))) -(define (re-search-buffer-forward pattern case-fold-search syntax-table - group start end) +(define (re-search-buffer-forward regexp syntax-table group start end) (let ((index ((ucode-primitive re-search-buffer-forward) - pattern - (re-translation-table case-fold-search) + (compiled-regexp/byte-stream regexp) + (compiled-regexp/translation-table regexp) (syntax-table-argument syntax-table) registers group start end))) (set! match-group (compute-match-group group index)) index)) -(define (re-search-buffer-backward pattern case-fold-search syntax-table - group start end) +(define (re-search-buffer-backward regexp syntax-table group start end) (let ((index ((ucode-primitive re-search-buffer-backward) - pattern - (re-translation-table case-fold-search) + (compiled-regexp/byte-stream regexp) + (compiled-regexp/translation-table regexp) (syntax-table-argument syntax-table) registers group start end))) (set! match-group (compute-match-group group index)) index)) -(define (re-match-buffer-forward pattern case-fold-search syntax-table - group start end) +(define (re-match-buffer-forward regexp syntax-table group start end) (let ((index ((ucode-primitive re-match-buffer) - pattern - (re-translation-table case-fold-search) + (compiled-regexp/byte-stream regexp) + (compiled-regexp/translation-table regexp) (syntax-table-argument syntax-table) registers group start end))) (set! match-group (compute-match-group group index)) @@ -221,43 +218,39 @@ (group-hash-number group) hash-of-false)) -(define (re-match-string-forward pattern case-fold-search syntax-table string) - (re-match-substring-forward pattern case-fold-search syntax-table +(define (re-match-string-forward regexp syntax-table string) + (re-match-substring-forward regexp syntax-table string 0 (string-length string))) -(define (re-match-substring-forward pattern case-fold-search syntax-table - string start end) +(define (re-match-substring-forward regexp syntax-table string start end) (set! match-group hash-of-false) ((ucode-primitive re-match-substring) - pattern - (re-translation-table case-fold-search) + (compiled-regexp/byte-stream regexp) + (compiled-regexp/translation-table regexp) (syntax-table-argument syntax-table) registers string start end)) -(define (re-search-string-forward pattern case-fold-search syntax-table string) - (re-search-substring-forward pattern case-fold-search syntax-table +(define (re-search-string-forward regexp syntax-table string) + (re-search-substring-forward regexp syntax-table string 0 (string-length string))) -(define (re-search-substring-forward pattern case-fold-search syntax-table - string start end) +(define (re-search-substring-forward regexp syntax-table string start end) (set! match-group hash-of-false) ((ucode-primitive re-search-substring-forward) - pattern - (re-translation-table case-fold-search) + (compiled-regexp/byte-stream regexp) + (compiled-regexp/translation-table regexp) (syntax-table-argument syntax-table) registers string start end)) -(define (re-search-string-backward pattern case-fold-search syntax-table - string) - (re-search-substring-backward pattern case-fold-search syntax-table +(define (re-search-string-backward regexp syntax-table string) + (re-search-substring-backward regexp syntax-table string 0 (string-length string))) -(define (re-search-substring-backward pattern case-fold-search syntax-table - string start end) +(define (re-search-substring-backward regexp syntax-table string start end) (set! match-group hash-of-false) ((ucode-primitive re-search-substring-backward) - pattern - (re-translation-table case-fold-search) + (compiled-regexp/byte-stream regexp) + (compiled-regexp/translation-table regexp) (syntax-table-argument syntax-table) registers string start end)) @@ -309,8 +302,9 @@ (define (%re-search string start end case-fold-search compile-string search) (let ((group (mark-group start))) (let ((index - (search (compile-string string case-fold-search) - case-fold-search + (search (if (compiled-regexp? string) + string + (compile-string string case-fold-search)) (group-syntax-table group) group (mark-index start) @@ -323,9 +317,10 @@ (case-fold-search (default-case-fold-search case-fold-search start)) (group (mark-group start))) (let ((index - (re-match-buffer-forward (re-compile-pattern regexp - case-fold-search) - case-fold-search + (re-match-buffer-forward (if (compiled-regexp? regexp) + regexp + (re-compile-pattern regexp + case-fold-search)) (group-syntax-table group) group (mark-index start) @@ -336,8 +331,9 @@ (define (re-string-match regexp string #!optional case-fold syntax-table) (let ((case-fold (if (default-object? case-fold) #f case-fold)) (syntax-table (if (default-object? syntax-table) #f syntax-table))) - (re-match-string-forward (re-compile-pattern regexp case-fold) - case-fold + (re-match-string-forward (if (compiled-regexp? regexp) + regexp + (re-compile-pattern regexp case-fold)) syntax-table string))) @@ -345,16 +341,18 @@ #!optional case-fold syntax-table) (let ((case-fold (if (default-object? case-fold) #f case-fold)) (syntax-table (if (default-object? syntax-table) #f syntax-table))) - (re-match-substring-forward (re-compile-pattern regexp case-fold) - case-fold + (re-match-substring-forward (if (compiled-regexp? regexp) + regexp + (re-compile-pattern regexp case-fold)) syntax-table string start end))) (define (re-string-search regexp string #!optional case-fold syntax-table) (let ((case-fold (if (default-object? case-fold) #f case-fold)) (syntax-table (if (default-object? syntax-table) #f syntax-table))) - (re-search-string-forward (re-compile-pattern regexp case-fold) - case-fold + (re-search-string-forward (if (compiled-regexp? regexp) + regexp + (re-compile-pattern regexp case-fold)) syntax-table string))) @@ -362,8 +360,9 @@ #!optional case-fold syntax-table) (let ((case-fold (if (default-object? case-fold) #f case-fold)) (syntax-table (if (default-object? syntax-table) #f syntax-table))) - (re-search-substring-forward (re-compile-pattern regexp case-fold) - case-fold + (re-search-substring-forward (if (compiled-regexp? regexp) + regexp + (re-compile-pattern regexp case-fold)) syntax-table string start end))) diff --git a/v7/src/edwin/rmail.scm b/v7/src/edwin/rmail.scm index 003231f8e..63a057f66 100644 --- a/v7/src/edwin/rmail.scm +++ b/v7/src/edwin/rmail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: rmail.scm,v 1.56 1997/01/15 07:09:05 cph Exp $ +;;; $Id: rmail.scm,v 1.57 1997/03/04 06:43:28 cph Exp $ ;;; ;;; Copyright (c) 1991-97 Massachusetts Institute of Technology ;;; @@ -1245,7 +1245,7 @@ original message into it." (let loop ((addresses addresses)) (cond ((null? addresses) '()) - ((re-match-string-forward pattern true false (car addresses)) + ((re-string-match pattern (car addresses)) (loop (cdr addresses))) (else (cons (car addresses) (loop (cdr addresses)))))))) @@ -1270,14 +1270,11 @@ original message into it." (message-id ;; Append from field to message-id if needed. (let ((from (rfc822-first-address from))) - (if (re-search-string-forward - (re-compile-string - (if (re-search-string-forward - (re-compile-pattern "@[^@]*\\'" #f) #f #f from) - (string-head from (re-match-start-index 0)) - from) - #t) - #t #f message-id) + (if (re-string-search + (if (re-string-search "@[^@]*\\'" from #f) + (string-head from (re-match-start-index 0)) + from) + message-id #t) message-id (string-append message-id " (" from ")")))) (else diff --git a/v7/src/edwin/rmailsrt.scm b/v7/src/edwin/rmailsrt.scm index 7941d7831..d7b998b02 100644 --- a/v7/src/edwin/rmailsrt.scm +++ b/v7/src/edwin/rmailsrt.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/rmailsrt.scm,v 1.8 1992/11/12 19:36:05 bal Exp $ +;;; $Id: rmailsrt.scm,v 1.9 1997/03/04 06:43:32 cph Exp $ ;;; -;;; Copyright (c) 1991 Massachusetts Institute of Technology +;;; Copyright (c) 1991-97 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -81,7 +81,7 @@ If prefix argument REVERSE is non-nil, sort them in reverse order." (msg-memo/end memo)) ""))) ;; Remove `Re:' - (if (re-match-string-forward re-pattern true false key) + (if (re-string-match re-pattern key) (string-tail key (re-match-end-index 0)) key)))) string') - (let loop ((the-pos 0)) - (let ((the-pattern - (re-compile-pattern - "[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*" - true))) - (set! pos - (re-match-substring-forward the-pattern true false address - the-pos (string-length address))) - (if pos - (if (and (> (string-length address) (re-match-end-index 0)) - (char=? (string-ref address (re-match-end-index 0)) #\@)) - (loop pos) - (begin - (set! address - (mail-string-delete address - the-pos (re-match-end-index 0))) - (loop the-pos)))))) - ;; Retain only part of address in <> delims, if there is such a thing. - (let loop () - (let ((the-pattern - (re-compile-pattern - "\\(,\\|\\`\\)[^,]*<\\([^>,]*>\\)" - true))) - (set! pos (re-search-string-forward the-pattern true false address)) - (if pos - (let ((junk-beg (re-match-end-index 1)) - (junk-end (re-match-start-index 2)) - (close (re-match-end-index 0))) - (set! address (mail-string-delete address (-1+ close) close)) - (set! address (mail-string-delete address junk-beg junk-end)) - (loop))))) - address))) + (if (re-string-search "\\`[ \t\n]*" address) + (set! address (string-tail address (re-match-end-index 0)))) + ;; strip surrounding whitespace + (if (re-string-search "[ \t\n]*\\'" address) + (set! address (string-head address (re-match-start-index 0)))) + (let loop () + (if (re-string-search "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*)" + address) + (begin + (set! address (mail-string-delete + address + (re-match-start-index 0) + (re-match-end-index 0))) + (loop)))) + ;; strip `quoted' names (This is supposed to hack `"Foo Bar" ') + (let loop ((the-pos 0)) + (let ((pos + (re-substring-match + "[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*" + address the-pos (string-length address)))) + (if pos + (if (and (> (string-length address) (re-match-end-index 0)) + (char=? (string-ref address (re-match-end-index 0)) #\@)) + (loop pos) + (begin + (set! address + (mail-string-delete address + the-pos (re-match-end-index 0))) + (loop the-pos)))))) + ;; Retain only part of address in <> delims, if there is such a thing. + (let loop () + (if (re-string-search "\\(,\\|\\`\\)[^,]*<\\([^>,]*>\\)" address) + (let ((junk-beg (re-match-end-index 1)) + (junk-end (re-match-start-index 2)) + (close (re-match-end-index 0))) + (set! address (mail-string-delete address (-1+ close) close)) + (set! address (mail-string-delete address junk-beg junk-end)) + (loop)))) + address)) \ No newline at end of file diff --git a/v7/src/edwin/rmailsum.scm b/v7/src/edwin/rmailsum.scm index 1ad14043c..83a6119d2 100644 --- a/v7/src/edwin/rmailsum.scm +++ b/v7/src/edwin/rmailsum.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: rmailsum.scm,v 1.32 1993/09/30 19:21:47 bal Exp $ +;;; $Id: rmailsum.scm,v 1.33 1997/03/04 06:43:34 cph Exp $ ;;; -;;; Copyright (c) 1991-93 Massachusetts Institute of Technology +;;; Copyright (c) 1991-97 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -48,7 +48,7 @@ (define-variable rmailsum-rcs-header "The RCS header of the rmailsum.scm file." - "$Id: rmailsum.scm,v 1.32 1993/09/30 19:21:47 bal Exp $" + "$Id: rmailsum.scm,v 1.33 1997/03/04 06:43:34 cph Exp $" string?) (define-variable-per-buffer rmail-buffer @@ -153,14 +153,11 @@ RECIPIENTS is a string of names separated by commas." (the-from-field (fetch-first-field "from" inner-start inner-end)) (the-cc-fields (fetch-all-fields "cc" inner-start inner-end))) (or (and the-to-field - (re-search-string-forward recip-regexp true false - the-to-field)) + (re-string-search recip-regexp the-to-field)) (and the-from-field - (re-search-string-forward recip-regexp true false - the-from-field)) + (re-string-search recip-regexp the-from-field)) (and (and (not primary-only) the-cc-fields) - (re-search-string-forward recip-regexp true false - the-cc-fields)))))))) + (re-string-search recip-regexp the-cc-fields)))))))) (define rmail-new-summary (lambda (description function . args) diff --git a/v7/src/edwin/shell.scm b/v7/src/edwin/shell.scm index 7b9442ad6..34c080bb6 100644 --- a/v7/src/edwin/shell.scm +++ b/v7/src/edwin/shell.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: shell.scm,v 1.13 1996/05/11 08:36:59 cph Exp $ +$Id: shell.scm,v 1.14 1997/03/04 06:43:37 cph Exp $ -Copyright (c) 1991-96 Massachusetts Institute of Technology +Copyright (c) 1991-97 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -155,19 +155,15 @@ Otherwise, one argument `-i' is passed to the shell." (define (shell-directory-tracker string) (if (ref-variable shell-dirtrack?) (let ((start - (re-match-string-forward (re-compile-pattern "^\\s *" false) - false - (ref-variable syntax-table) - string)) + (re-string-match "^\\s *" string #f (ref-variable syntax-table))) (end (string-length string))) (let ((try (let ((match (lambda (regexp start) - (re-match-substring-forward - (re-compile-pattern regexp false) - false - (ref-variable syntax-table) - string start end)))) + (re-substring-match regexp + string start end + #f + (ref-variable syntax-table))))) (lambda (command) (let ((eoc (match command start))) (cond ((not eoc) @@ -235,8 +231,7 @@ Otherwise, one argument `-i' is passed to the shell." (shell-dirstack-message))))) (define (shell-extract-num string) - (and (re-match-string-forward (re-compile-pattern "^\\+[1-9][0-9]*$" false) - false false string) + (and (re-string-match "^\\+[1-9][0-9]*$" string) (string->number string))) (define (shell-process-cd filename) diff --git a/v7/src/edwin/snr.scm b/v7/src/edwin/snr.scm index 0af8c4470..cba1333ed 100644 --- a/v7/src/edwin/snr.scm +++ b/v7/src/edwin/snr.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: snr.scm,v 1.27 1997/02/23 06:24:43 cph Exp $ +;;; $Id: snr.scm,v 1.28 1997/03/04 06:43:40 cph Exp $ ;;; ;;; Copyright (c) 1995-97 Massachusetts Institute of Technology ;;; @@ -2267,23 +2267,14 @@ This kills the current buffer." (let ((regexp (ref-variable rmail-ignored-headers hstart))) (if regexp (let ((point (mark-right-inserting-copy hstart)) - (group (mark-group hstart)) (p1 (re-compile-pattern regexp #t)) (p2 (re-compile-pattern "\n[^ \t]" #f))) (do () - ((not (re-search-buffer-forward p1 #t #f - group - (mark-index point) - (mark-index hend)))) + ((not (re-search-forward p1 point hend))) (move-mark-to! point (line-start (re-match-start 0) 0)) (delete-string point - (make-mark group - (fix:- (re-search-buffer-forward p2 #f #f - group - (mark-index point) - (mark-index hend)) - 1)))) + (mark-1+ (re-search-forward p2 point hend)))) (mark-temporary! point))))) (define (delete-news-header buffer) diff --git a/v7/src/edwin/strtab.scm b/v7/src/edwin/strtab.scm index 8e324492e..eb3cdbb5c 100644 --- a/v7/src/edwin/strtab.scm +++ b/v7/src/edwin/strtab.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: strtab.scm,v 1.44 1993/08/10 07:05:47 cph Exp $ +;;; $Id: strtab.scm,v 1.45 1997/03/04 06:43:44 cph Exp $ ;;; -;;; Copyright (c) 1985, 1989-93 Massachusetts Institute of Technology +;;; Copyright (c) 1985, 1989-97 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -160,18 +160,14 @@ (define (string-table-apropos table regexp) (let ((end (string-table-size table)) - (case-fold-search (string-table-ci? table))) - (let ((pattern (re-compile-pattern regexp case-fold-search))) - (let loop ((index 0)) - (if (= index end) - '() - (let ((entry (vector-ref (string-table-vector table) index))) - (if (re-search-string-forward pattern - case-fold-search - false - (string-table-entry-string entry)) - (cons (string-table-entry-value entry) (loop (1+ index))) - (loop (1+ index))))))))) + (pattern (re-compile-pattern regexp (string-table-ci? table)))) + (let loop ((index 0)) + (if (= index end) + '() + (let ((entry (vector-ref (string-table-vector table) index))) + (if (re-string-search pattern (string-table-entry-string entry)) + (cons (string-table-entry-value entry) (loop (1+ index))) + (loop (1+ index)))))))) (define (%string-table-complete table string if-unique if-not-unique if-not-found) diff --git a/v7/src/edwin/telnet.scm b/v7/src/edwin/telnet.scm index 0d37ad29f..22fb68da4 100644 --- a/v7/src/edwin/telnet.scm +++ b/v7/src/edwin/telnet.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: telnet.scm,v 1.9 1993/02/14 23:14:18 gjr Exp $ +$Id: telnet.scm,v 1.10 1997/03/04 06:43:46 cph Exp $ -Copyright (c) 1991-1993 Massachusetts Institute of Technology +Copyright (c) 1991-97 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -84,11 +84,7 @@ use it instead of the default." (if (not new-process?) buffer-name (new-buffer buffer-name))))) - (if (re-match-string-forward - (re-compile-pattern "\\([^ ]+\\) \\([^ ]+\\)" false) - true - false - host) + (if (re-string-match "\\([^ ]+\\) \\([^ ]+\\)" host) (let ((host (substring host (re-match-start-index 1) diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm index f78345b11..d36dd7725 100644 --- a/v7/src/edwin/unix.scm +++ b/v7/src/edwin/unix.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: unix.scm,v 1.74 1996/12/24 22:32:15 cph Exp $ +;;; $Id: unix.scm,v 1.75 1997/03/04 06:43:49 cph Exp $ ;;; -;;; Copyright (c) 1989-96 Massachusetts Institute of Technology +;;; Copyright (c) 1989-97 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -94,9 +94,7 @@ Includes the new backup. Must be > 0." (or (fix:= index (string-length prefix)) (and (fix:> index 0) (char=? (string-ref prefix (fix:- index 1)) #\/))) - (re-match-substring-forward (re-compile-pattern "[/$~]" #t) - #t #f string index - (string-length string))) + (re-substring-match "[/$~]" string index (string-length string))) (string-tail string index) string))) @@ -215,8 +213,8 @@ Includes the new backup. Must be > 0." (let loop ((filenames filenames)) (cond ((null? filenames) '()) - ((re-match-substring-forward - pattern false false + ((re-substring-match + pattern (car filenames) prefix-length (string-length (car filenames))) diff --git a/v7/src/edwin/verilog.scm b/v7/src/edwin/verilog.scm index 6a0093aa9..3c5f40434 100644 --- a/v7/src/edwin/verilog.scm +++ b/v7/src/edwin/verilog.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: verilog.scm,v 1.1 1996/04/23 22:39:44 cph Exp $ +;;; $Id: verilog.scm,v 1.2 1997/03/04 06:43:51 cph Exp $ ;;; -;;; Copyright (c) 1996 Massachusetts Institute of Technology +;;; Copyright (c) 1996-97 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -293,7 +293,7 @@ (define (match-statement-keyword start) (let loop ((records verilog-statement-keywords)) (and (not (null? records)) - (if (match-pattern (keyword-record/pattern (car records)) start) + (if (re-match-forward (keyword-record/pattern (car records)) start) (car records) (loop (cdr records)))))) @@ -301,16 +301,7 @@ (let ((record (and (pair? nesting) (cdar nesting)))) (and record (keyword-record/ending-pattern record) - (match-pattern (keyword-record/ending-pattern record) mark)))) - -(define (match-pattern pattern mark) - (let ((group (mark-group mark))) - (re-match-buffer-forward pattern - #f - (group-syntax-table group) - group - (mark-index mark) - (group-end-index group)))) + (re-match-forward (keyword-record/ending-pattern record) mark)))) (define (parse-forward-past-semicolon start end) (let loop ((start start) (state #f)) diff --git a/v7/src/runtime/rgxcmp.scm b/v7/src/runtime/rgxcmp.scm index 6b1862585..1c2a21f26 100644 --- a/v7/src/runtime/rgxcmp.scm +++ b/v7/src/runtime/rgxcmp.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: rgxcmp.scm,v 1.107 1995/10/19 08:39:38 cph Exp $ +;;; $Id: rgxcmp.scm,v 1.108 1997/03/04 06:43:26 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-95 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-97 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -193,7 +193,7 @@ (let ((result (string-allocate 2))) (vector-8b-set! result 0 re-code:exact-1) (string-set! result 1 (if case-fold? (char-upcase char) char)) - result)) + (make-compiled-regexp result case-fold?))) (define re-compile-string (cached-procedure 16 @@ -201,7 +201,7 @@ (let ((string (if case-fold? (string-upcase string) string))) (let ((n (string-length string))) (if (fix:zero? n) - string + (make-compiled-regexp string case-fold?) (let ((result (string-allocate (let ((qr (integer-divide n 255))) @@ -216,13 +216,13 @@ (vector-8b-set! result (fix:1+ p) (vector-8b-ref string i)) - result) + (make-compiled-regexp result case-fold?)) ((fix:< n 256) (vector-8b-set! result p re-code:exact-n) (vector-8b-set! result (fix:1+ p) n) (substring-move-right! string i (fix:+ i n) result (fix:+ p 2)) - result) + (make-compiled-regexp result case-fold?)) (else (vector-8b-set! result p re-code:exact-n) (vector-8b-set! result (fix:1+ p) 255) @@ -358,6 +358,15 @@ '(MESSAGE) standard-error-handler)) +(define-structure (compiled-regexp + (constructor %make-compiled-regexp) + (conc-name compiled-regexp/)) + (byte-stream #f read-only #t) + (translation-table #f read-only #t)) + +(define (make-compiled-regexp byte-stream case-fold?) + (%make-compiled-regexp byte-stream (re-translation-table case-fold?))) + (define input-list) (define current-byte) (define translation-table) @@ -396,7 +405,9 @@ (store-jump! fixup-jump re-code:jump (output-position))) (if (not (stack-empty?)) (compilation-error "Unmatched \\(")) - (list->string (map ascii->char (cdr output-head)))) + (make-compiled-regexp + (list->string (map ascii->char (cdr output-head))) + case-fold?)) (begin (compile-pattern-char) (loop))))))))) -- 2.25.1