#| -*-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
(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
"/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)))))))
\f
(define (month-name->number month)
(let ((months
(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 =)))
;;; -*-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
;;;
(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)
;;; -*-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
;;;
(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))))
;;; -*-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
;;;
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*"
;;; -*-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
;;;
;; 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 ")"))))
;;; -*-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
;;;
(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)))))
string<?)))
(define-command rmail-sort-by-author
("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
- ;; (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
- (if (re-string-search-forward
- "\\([0-9]+\\) \\([^ ,]+\\) \\([0-9]+\\)[ ]+\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\):?\\([0-9]*\\)"
- date)
- (string-append
- ;; Year
- (let ((year
- (string->number
- (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)))))
\f
(define mail-string-delete
(lambda (string start end)
(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" <bar@host>')
(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
#| -*-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
(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
#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))
;;; -*-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
;;;
(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))))
\f
(define (news-group-buffer:header-mark buffer header)
(let ((index (news-header:index header)))
#| -*-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
(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)
;;; -*-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
;;;
(list "\\)")
(cons "\\|" (loop (cdr alternatives)))))))))))
\f
-(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)
(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
(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))))
projects / mit-scheme.git / commitdiff