From: Chris Hanson Date: Fri, 20 Aug 1999 20:35:56 +0000 (+0000) Subject: Change string/substring regular-expression procedures to return a X-Git-Tag: 20090517-FFI~4464 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=22c04960b96475fa3b05c4267d9faafc2cfddfba;p=mit-scheme.git Change string/substring regular-expression procedures to return a set of registers on a successful match rather than modifying a global set of registers. This fixes the problem in which an unlucky thread switch can generate an error or incorrect answer. --- diff --git a/v7/src/6001/floppy.scm b/v7/src/6001/floppy.scm index f1363df43..98f320a45 100644 --- a/v7/src/6001/floppy.scm +++ b/v7/src/6001/floppy.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: floppy.scm,v 1.25 1999/01/28 04:01:08 cph Exp $ +$Id: floppy.scm,v 1.26 1999/08/20 20:35:56 cph Exp $ Copyright (c) 1992-1999 Massachusetts Institute of Technology @@ -610,9 +610,10 @@ M-x rename-file, or use the `r' command in Dired.") (let ((offset (time-zone-offset))) (let loop ((start - (if (re-substring-match leader-pattern string start end) - (re-match-end-index 0) - start))) + (let ((r (re-substring-match leader-pattern string start end))) + (if r + (re-match-end-index 0 r) + start)))) (if (= start end) '() (let ((eol @@ -638,22 +639,23 @@ M-x rename-file, or use the `r' command in Dired.") "/dev/rfd:/\\(.+\\) *$") false))) (lambda (string start end offset) - (if (not (re-substring-match line-pattern string start end)) - (error "Line doesn't match dosls -l pattern:" - (substring string start end))) - (let ((month (extract-string-match string 1)) - (day (extract-string-match string 2)) - (year (extract-string-match string 3)) - (hour (extract-string-match string 4)) - (minute (extract-string-match string 5)) - (filename (extract-string-match string 6))) - (values (string-downcase filename) - (+ (make-dos-time (string->number year) - (month-name->number month) - (string->number day) - (string->number hour) - (string->number minute)) - offset)))))) + (let ((r (re-substring-match line-pattern string start end))) + (if (not r) + (error "Line doesn't match dosls -l pattern:" + (substring string start end))) + (let ((month (extract-string-match string r 1)) + (day (extract-string-match string r 2)) + (year (extract-string-match string r 3)) + (hour (extract-string-match string r 4)) + (minute (extract-string-match string r 5)) + (filename (extract-string-match string r 6))) + (values (string-downcase filename) + (+ (make-dos-time (string->number year) + (month-name->number month) + (string->number day) + (string->number hour) + (string->number minute)) + offset))))))) (define (month-name->number month) (let ((months @@ -855,8 +857,8 @@ M-x rename-file, or use the `r' command in Dired.") (define (directory-filename? filename) (char=? #\/ (string-ref filename (- (string-length filename) 1)))) -(define (extract-string-match string n) - (substring string (re-match-start-index n) (re-match-end-index n))) +(define (extract-string-match string r n) + (substring string (re-match-start-index n r) (re-match-end-index n r))) (define (three-way-sort = set set*) (let ((member? (member-procedure =))) diff --git a/v7/src/edwin/dosfile.scm b/v7/src/edwin/dosfile.scm index 188b62345..4af8deff6 100644 --- a/v7/src/edwin/dosfile.scm +++ b/v7/src/edwin/dosfile.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dosfile.scm,v 1.30 1999/08/10 16:54:41 cph Exp $ +;;; $Id: dosfile.scm,v 1.31 1999/08/20 20:34:20 cph Exp $ ;;; ;;; Copyright (c) 1994-1999 Massachusetts Institute of Technology ;;; @@ -290,24 +290,28 @@ Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'." (re-string-match ".[0-9][0-9]" type)))))) (define (os/numeric-backup-filename? filename) - (and (let ((try - (lambda (pattern) (re-string-search-forward pattern filename)))) - (or (try "^\\([^.]+\\)\\.\\([0-9][0-9][0-9]\\)$") - (try "^\\([^.]+\\.[^.]\\)\\([0-9][0-9]\\)$") - (there-exists? dos/backup-suffixes - (lambda (suffix) - (try (string-append "^\\(.+\\)\\.~\\([0-9]+\\)" - (re-quote-string suffix) - "$")))))) - (let ((root-start (re-match-start-index 1)) - (root-end (re-match-end-index 1)) - (version-start (re-match-start-index 2)) - (version-end (re-match-end-index 2))) - (let ((version - (substring->number filename version-start version-end))) - (and (> version 0) - (cons (substring filename root-start root-end) - version)))))) + (let ((r + (let ((try + (lambda (pattern) + (re-string-search-forward pattern filename)))) + (or (try "^\\([^.]+\\)\\.\\([0-9][0-9][0-9]\\)$") + (try "^\\([^.]+\\.[^.]\\)\\([0-9][0-9]\\)$") + (let loop ((suffixes dos/backup-suffixes)) + (if (pair? suffixes) + (or (try (string-append "^\\(.+\\)\\.~\\([0-9]+\\)" + (re-quote-string (car suffixes)) + "$")) + (loop (cdr suffixes))))))))) + (and r + (let ((root-start (re-match-start-index 1 r)) + (root-end (re-match-end-index 1 r)) + (version-start (re-match-start-index 2 r)) + (version-end (re-match-end-index 2 r))) + (let ((version + (substring->number filename version-start version-end))) + (and (> version 0) + (cons (substring filename root-start root-end) + version))))))) (define (os/auto-save-filename? filename) (if (dos/fs-long-filenames? filename) diff --git a/v7/src/edwin/malias.scm b/v7/src/edwin/malias.scm index 7e410d1ae..4d204a16e 100644 --- a/v7/src/edwin/malias.scm +++ b/v7/src/edwin/malias.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: malias.scm,v 1.4 1999/01/02 06:11:34 cph Exp $ +;;; $Id: malias.scm,v 1.5 1999/08/20 20:35:45 cph Exp $ ;;; ;;; Copyright (c) 1991-1999 Massachusetts Institute of Technology ;;; @@ -120,11 +120,12 @@ (let loop () (let ((line (read-mailrc-line port))) (if line - (let ((index + (let ((r (re-string-match "^\\(a\\|alias\\|g\\|group\\)[ \t]+" line))) - (if index - (let ((parsed-line (parse-mailrc-line line index))) + (if r + (let ((parsed-line + (parse-mailrc-line line (re-match-end-index 0 r)))) (if (null? (cdr parsed-line)) (loop) (cons parsed-line (loop)))) diff --git a/v7/src/edwin/manual.scm b/v7/src/edwin/manual.scm index ed61da177..5fec15c9b 100644 --- a/v7/src/edwin/manual.scm +++ b/v7/src/edwin/manual.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: manual.scm,v 1.15 1999/01/02 06:11:34 cph Exp $ +;;; $Id: manual.scm,v 1.16 1999/08/20 20:35:51 cph Exp $ ;;; ;;; Copyright (c) 1991-1999 Massachusetts Institute of Technology ;;; @@ -28,20 +28,22 @@ TOPIC is either the title of the entry, or has the form TITLE(SECTION) 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-string-match - "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" - topic)) - (begin - (set! section - (substring topic - (re-match-start-index 2) - (re-match-end-index 2))) - (set! topic - (substring topic - (re-match-start-index 1) - (re-match-end-index 1)))) - (set! section false)) + (let ((r + (and (default-object? section) + (re-string-match + "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" + topic)))) + (if r + (begin + (set! section + (substring topic + (re-match-start-index 2 r) + (re-match-end-index 2 r))) + (set! topic + (substring topic + (re-match-start-index 1 r) + (re-match-end-index 1 r)))) + (set! section false))) (let ((buffer-name (if (ref-variable manual-entry-reuse-buffer?) "*Manual-Entry*" diff --git a/v7/src/edwin/rmail.scm b/v7/src/edwin/rmail.scm index 3c8cd9b54..5ef139b52 100644 --- a/v7/src/edwin/rmail.scm +++ b/v7/src/edwin/rmail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: rmail.scm,v 1.63 1999/08/10 16:54:54 cph Exp $ +;;; $Id: rmail.scm,v 1.64 1999/08/20 20:34:24 cph Exp $ ;;; ;;; Copyright (c) 1991-1999 Massachusetts Institute of Technology ;;; @@ -1250,9 +1250,10 @@ original message into it." ;; Append from field to message-id if needed. (let ((from (rfc822-first-address from))) (if (re-string-search-forward - (if (re-string-search-forward "@[^@]*\\'" from #f) - (string-head from (re-match-start-index 0)) - from) + (let ((r (re-string-search-forward "@[^@]*\\'" from #f))) + (if r + (string-head from (re-match-start-index 0 r)) + from)) message-id #t) message-id (string-append message-id " (" from ")")))) diff --git a/v7/src/edwin/rmailsrt.scm b/v7/src/edwin/rmailsrt.scm index 95998bfba..f25703e72 100644 --- a/v7/src/edwin/rmailsrt.scm +++ b/v7/src/edwin/rmailsrt.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: rmailsrt.scm,v 1.11 1999/05/13 03:06:45 cph Exp $ +;;; $Id: rmailsrt.scm,v 1.12 1999/08/20 20:35:39 cph Exp $ ;;; ;;; Copyright (c) 1991-1999 Massachusetts Institute of Technology ;;; @@ -57,9 +57,10 @@ If prefix argument REVERSE is non-nil, sort them in reverse order." (msg-memo/end memo)) ""))) ;; Remove `Re:' - (if (re-string-match re-pattern key) - (string-tail key (re-match-end-index 0)) - key)))) + (let ((r (re-string-match re-pattern key))) + (if r + (string-tail key (re-match-end-index 0 r)) + key))))) stringnumber - (substring date - (re-match-start-index 3) - (re-match-end-index 3))))) - (let ((y1 (modulo year 100))) - (string-pad-left (number->string y1) 2))) - ;; Month - (cdr - (assoc - (string-upcase - (substring (substring date - (re-match-start-index 2) - (re-match-end-index 2)) - 0 3)) - month)) - ;; Day - (let ((day - (substring date - (re-match-start-index 1) - (re-match-end-index 1)))) - (string-pad-left day 2 #\0)) - ;; Time - (string-pad-left - (substring date (re-match-start-index 4) (re-match-end-index 4)) - 2 #\0) - (substring date (re-match-start-index 5) (re-match-end-index 5)) - (substring date (re-match-start-index 6) (re-match-end-index 6))) - ;; Cannot understand DATE string. - date)))) + ;; Can understand the following styles: + ;; (1) 14 Apr 89 03:20:12 GMT + ;; (2) Fri, 17 Mar 89 4:01:33 GMT + ;; (3) Fri, 3 Apr 92 18:55 EST + ;; + ;; added [ ]+ to the regexp to handle date string put out + ;; by hx.lcs.mit.edu (they use 2 spaces instead of 1) + ;; made seconds optional since research.att.com doesn't send it out + (let ((r + (re-string-search-forward + "\\([0-9]+\\) \\([^ ,]+\\) \\([0-9]+\\)[ ]+\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\):?\\([0-9]*\\)" + date))) + (if r + (string-append + ;; Year + (let ((year + (string->number + (substring date + (re-match-start-index 3 r) + (re-match-end-index 3 r))))) + (let ((y1 (modulo year 100))) + (string-pad-left (number->string y1) 2))) + ;; Month + (cdr + (assoc + (string-upcase + (substring (substring date + (re-match-start-index 2 r) + (re-match-end-index 2 r)) + 0 3)) + month)) + ;; Day + (let ((day + (substring date + (re-match-start-index 1 r) + (re-match-end-index 1 r)))) + (string-pad-left day 2 #\0)) + ;; Time + (string-pad-left + (substring date + (re-match-start-index 4 r) + (re-match-end-index 4 r)) + 2 #\0) + (substring date + (re-match-start-index 5 r) + (re-match-end-index 5 r)) + (substring date + (re-match-start-index 6 r) + (re-match-end-index 6 r))) + ;; Cannot understand DATE string. + date))))) (define mail-string-delete (lambda (string start end) @@ -226,42 +235,49 @@ If prefix argument REVERSE is non-nil, sort them in reverse order." (define mail-strip-quoted-names (lambda (address) - (if (re-string-search-forward "\\`[ \t\n]*" address) - (set! address (string-tail address (re-match-end-index 0)))) + (let ((r (re-string-search-forward "\\`[ \t\n]*" address))) + (if r + (set! address (string-tail address (re-match-end-index 0 r))))) ;; strip surrounding whitespace - (if (re-string-search-forward "[ \t\n]*\\'" address) - (set! address (string-head address (re-match-start-index 0)))) + (let ((r (re-string-search-forward "[ \t\n]*\\'" address))) + (if r + (set! address (string-head address (re-match-start-index 0 r))))) (let loop () - (if (re-string-search-forward "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*)" - address) - (begin - (set! address (mail-string-delete - address - (re-match-start-index 0) - (re-match-end-index 0))) - (loop)))) + (let ((r + (re-string-search-forward + "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*)" + address))) + (if r + (begin + (set! address + (mail-string-delete address + (re-match-start-index 0 r) + (re-match-end-index 0 r))) + (loop))))) ;; strip `quoted' names (This is supposed to hack `"Foo Bar" ') (let loop ((the-pos 0)) - (let ((pos + (let ((r (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)))))) + (if r + (let ((pos (re-match-end-index 0 r))) + (if (and (> (string-length address) pos) + (char=? (string-ref address pos) #\@)) + (loop pos) + (begin + (set! address (mail-string-delete address the-pos pos)) + (loop the-pos))))))) ;; Retain only part of address in <> delims, if there is such a thing. (let loop () - (if (re-string-search-forward "\\(,\\|\\`\\)[^,]*<\\([^>,]*>\\)" 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)))) + (let ((r + (re-string-search-forward "\\(,\\|\\`\\)[^,]*<\\([^>,]*>\\)" + address))) + (if r + (let ((junk-beg (re-match-end-index 1 r)) + (junk-end (re-match-start-index 2 r)) + (close (re-match-end-index 0 r))) + (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/shell.scm b/v7/src/edwin/shell.scm index d69c2bf71..df9a71e99 100644 --- a/v7/src/edwin/shell.scm +++ b/v7/src/edwin/shell.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: shell.scm,v 1.19 1999/01/02 06:11:34 cph Exp $ +$Id: shell.scm,v 1.20 1999/08/20 20:35:42 cph Exp $ Copyright (c) 1991-1999 Massachusetts Institute of Technology @@ -139,7 +139,12 @@ Otherwise, one argument `-i' is passed to the shell." (define (shell-directory-tracker string) (if (ref-variable shell-dirtrack?) (let ((start - (re-string-match "^\\s *" string #f (ref-variable syntax-table))) + (let ((r + (re-string-match "^\\s *" string #f + (ref-variable syntax-table)))) + (if r + (re-match-end-index 0 r) + 0))) (end (string-length string))) (let ((try (let ((match @@ -149,16 +154,18 @@ Otherwise, one argument `-i' is passed to the shell." #f (ref-variable syntax-table))))) (lambda (command) - (let ((eoc (match command start))) - (cond ((not eoc) - false) - ((match "\\s *\\(\;\\|$\\)" eoc) - "") + (let ((eoc + (let ((r (match command start))) + (and r + (re-match-end-index r))))) + (cond ((not eoc) #f) + ((match "\\s *\\(\;\\|$\\)" eoc) "") ((match "\\s +\\([^ \t\;]+\\)\\s *\\(\;\\|$\\)" eoc) - (substring string - (re-match-start-index 1) - (re-match-end-index 1))) - (else false))))))) + => (lambda (r) + (substring string + (re-match-start-index 1 r) + (re-match-end-index 1 r)))) + (else #f))))))) (cond ((try (ref-variable shell-cd-regexp)) => shell-process-cd) ((try (ref-variable shell-pushd-regexp)) diff --git a/v7/src/edwin/snr.scm b/v7/src/edwin/snr.scm index 675b6497c..9dd88d253 100644 --- a/v7/src/edwin/snr.scm +++ b/v7/src/edwin/snr.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: snr.scm,v 1.51 1999/01/28 04:00:03 cph Exp $ +;;; $Id: snr.scm,v 1.52 1999/08/20 20:35:53 cph Exp $ ;;; ;;; Copyright (c) 1995-1999 Massachusetts Institute of Technology ;;; @@ -1377,14 +1377,16 @@ This shows News groups that have been created since the last time that (mark-temporary! start))) (define (compose-author-string from mark) - (if (and (ref-variable news-group-show-author-name mark) - (or (re-string-match "^\"\\(.+\\)\"[ \t]+<.+>$" from) - (re-string-match "^\\(.+\\)<.+>$" from) - (re-string-match "^[^ \t]+[ \t]+(\\(.+\\))$" from))) - (string-trim (substring from - (re-match-start-index 1) - (re-match-end-index 1))) - (or (rfc822-first-address from) from))) + (let ((r + (and (ref-variable news-group-show-author-name mark) + (or (re-string-match "^\"\\(.+\\)\"[ \t]+<.+>$" from) + (re-string-match "^\\(.+\\)<.+>$" from) + (re-string-match "^[^ \t]+[ \t]+(\\(.+\\))$" from))))) + (if r + (string-trim (substring from + (re-match-start-index 1 r) + (re-match-end-index 1 r))) + (or (rfc822-first-address from) from)))) (define (news-group-buffer:header-mark buffer header) (let ((index (news-header:index header))) diff --git a/v7/src/edwin/telnet.scm b/v7/src/edwin/telnet.scm index b041e3f94..0e00c7a83 100644 --- a/v7/src/edwin/telnet.scm +++ b/v7/src/edwin/telnet.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: telnet.scm,v 1.14 1999/01/02 06:11:34 cph Exp $ +$Id: telnet.scm,v 1.15 1999/08/20 20:35:48 cph Exp $ Copyright (c) 1991-1999 Massachusetts Institute of Technology @@ -70,19 +70,20 @@ use it instead of the default." (if (not new-process?) buffer-name (new-buffer buffer-name))))) - (if (re-string-match "\\([^ ]+\\) \\([^ ]+\\)" host) - (let ((host - (substring host - (re-match-start-index 1) - (re-match-end-index 1))) - (port - (substring host - (re-match-start-index 2) - (re-match-end-index 2)))) - (if (not (exact-nonnegative-integer? (string->number port))) - (editor-error "Port must be a positive integer: " port)) - (make-comint mode buffer-name "telnet" host port)) - (make-comint mode buffer-name "telnet" host)))))) + (let ((r (re-string-match "\\([^ ]+\\) \\([^ ]+\\)" host))) + (if r + (let ((host + (substring host + (re-match-start-index 1 r) + (re-match-end-index 1 r))) + (port + (substring host + (re-match-start-index 2 r) + (re-match-end-index 2 r)))) + (if (not (exact-nonnegative-integer? (string->number port))) + (editor-error "Port must be a positive integer: " port)) + (make-comint mode buffer-name "telnet" host port)) + (make-comint mode buffer-name "telnet" host))))))) (add-event-receiver! (ref-variable telnet-mode-hook) comint-strip-carriage-returns) diff --git a/v7/src/runtime/regexp.scm b/v7/src/runtime/regexp.scm index 15a4027ba..6abb536d6 100644 --- a/v7/src/runtime/regexp.scm +++ b/v7/src/runtime/regexp.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: regexp.scm,v 1.3 1999/06/22 18:07:19 cph Exp $ +;;; $Id: regexp.scm,v 1.4 1999/08/20 20:34:12 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology ;;; @@ -84,7 +84,7 @@ (list "\\)") (cons "\\|" (loop (cdr alternatives))))))))))) -(define (make-substring-operation return-end? primitive) +(define (make-substring-operation name primitive) (lambda (regexp string start end #!optional case-fold? syntax-table) (let ((regexp (if (compiled-regexp? regexp) @@ -92,7 +92,8 @@ (re-compile-pattern regexp (if (default-object? case-fold?) #f - case-fold?))))) + case-fold?)))) + (regs (make-vector 20 #f))) (and (primitive (compiled-regexp/byte-stream regexp) (compiled-regexp/translation-table regexp) (char-syntax-table/entries @@ -100,20 +101,23 @@ (not syntax-table)) standard-char-syntax-table syntax-table)) - registers string start end) - (vector-ref registers (if return-end? 10 0)))))) + regs string start end) + (make-re-registers regs))))) (define re-substring-match - (make-substring-operation #t (ucode-primitive re-match-substring))) + (make-substring-operation 'RE-SUBSTRING-MATCH + (ucode-primitive re-match-substring))) (define re-substring-search-forward - (make-substring-operation #f (ucode-primitive re-search-substring-forward))) + (make-substring-operation 'RE-SUBSTRING-SEARCH-FORWARD + (ucode-primitive re-search-substring-forward))) (define re-substring-search-backward - (make-substring-operation #t (ucode-primitive re-search-substring-backward))) + (make-substring-operation 'RE-SUBSTRING-SEARCH-BACKWARD + (ucode-primitive re-search-substring-backward))) (define (make-string-operation substring-operation) - (lambda (regexp string #!optional case-fold? syntax-table) + (lambda (regexp string #!optional case-fold? regs syntax-table) (substring-operation regexp string 0 (string-length string) (if (default-object? case-fold?) #f case-fold?) (if (default-object? syntax-table) #f syntax-table))))