#| -*-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
(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
#| -*-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
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
;;; -*-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
;;;
(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)
\f
;;; -*-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
(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
;;; -*-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
(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)))
(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
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)))))
#| -*-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
(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
;;; -*-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
(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)))
;;; -*-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
;;;
(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
(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
;;; -*-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
(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))
;;; -*-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
"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
(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
;;; -*-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
(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)))
\f
(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)))
(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)))))
\f
(define-major-mode occur fundamental "Occur"
"Major mode for output from \\[occur].
(command-procedure (ref-command-object occur)))
\f
(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)
;;; -*-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
;;;
(group-delete! group start (re-match-end-index 0))
(make-mark group start)))
\f
-(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))
(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))
\f
(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)
(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)
(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)))
#!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)))
#!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)))
;;; -*-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
;;;
(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))))))))
(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
;;; -*-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
(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<?)))
(define rmail-sortable-date-string
(lambda (date)
- (let ((month '(("JAN" . "01")("FEB" . "02")("MAR" . "03")
- ("APR" . "04")("MAY" . "05")("JUN" . "06")
- ("JUL" . "07")("AUG" . "08")("SEP" . "09")
- ("OCT" . "10")("NOV" . "11")("DEC" . "12")
- ("JANUARY" . "01")("FEBRUARY" . "02")("MARCH" . "03")
- ("APRIL" . "04")("JUNE" . "06")("JULY" . "07")
- ("AUGUST" . "08")("SEPTEMBER" . "09")("OCTOBER" . "10")
- ("NOVEMBER" . "11")("DECEMBER" . "12")))
+ (let ((month '(("JAN" . "01")
+ ("FEB" . "02")("MAR" . "03")
+ ("APR" . "04")("MAY" . "05")("JUN" . "06")
+ ("JUL" . "07")("AUG" . "08")("SEP" . "09")
+ ("OCT" . "10")("NOV" . "11")("DEC" . "12")
+ ("JANUARY" . "01")("FEBRUARY" . "02")("MARCH" . "03")
+ ("APRIL" . "04")("JUNE" . "06")("JULY" . "07")
+ ("AUGUST" . "08")("SEPTEMBER" . "09")("OCTOBER" . "10")
+ ("NOVEMBER" . "11")("DECEMBER" . "12")))
(date (or date "")))
;; Can understand the following styles:
;; (1) 14 Apr 89 03:20:12 GMT
;; 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
- (if (re-search-string-forward
- (re-compile-pattern
- "\\([0-9]+\\) \\([^ ,]+\\) \\([0-9]+\\)[ ]+\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\):?\\([0-9]*\\)" true)
- true false date)
+ (if (re-string-search
+ "\\([0-9]+\\) \\([^ ,]+\\) \\([0-9]+\\)[ ]+\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\):?\\([0-9]*\\)"
+ date)
(string-append
;; Year
(let ((year
(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 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.
(define mail-strip-quoted-names
(lambda (address)
- (let ((pos))
- (if (re-search-string-forward (re-compile-pattern "\\`[ \t\n]*" true)
- true false address)
- (set! address (string-tail address (re-match-end-index 0))))
- ;; strip surrounding whitespace
- (if (re-search-string-forward (re-compile-pattern "[ \t\n]*\\'" true)
- true false address)
- (set! address (string-head address (re-match-start-index 0))))
- (let loop ()
- (let ((the-pattern
- (re-compile-pattern
- "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*)" true)))
- (set! pos (re-search-string-forward the-pattern true false address))
- (if pos
- (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" <bar@host>')
- (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" <bar@host>')
+ (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
;;; -*-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
\f
(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
(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))))))))
\f
(define rmail-new-summary
(lambda (description function . args)
#| -*-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
(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)
(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)))
\f
(define (shell-process-cd filename)
;;; -*-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
;;;
(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)
;;; -*-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
(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))))))))
\f
(define (%string-table-complete table string
if-unique if-not-unique if-not-found)
#| -*-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
(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)
;;; -*-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
(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)))
(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)))
;;; -*-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
(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))))))
(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))
;;; -*-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
(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
(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)))
(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)
'(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)
(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)))))))))
projects / mit-scheme.git / commitdiff