* Implement M-x append-to-file, M-x tabify, C-u M-x indent-region.
* Change M-x undo to move point to the location of the most recent
undone change. This restores the behavior that was in effect before
the last change to undo.
* Implement variable `enable-emacs-write-file-message', by default
true, which changes file-output messages to be like Emacs.
* Fix simple bugs in auto save code, local variable binding.
* Add new slot to buffer, LOCAL-BINDINGS-INSTALLED?, that speeds up
the test to determine if the buffer's local bindings are the ones
currently installed in the variable value cells.
* Reimplement character search, character match, and string match.
New implementation does not use regular expression primitives.
A new set of low-level search and match primitives provides more
power than the old ones did.
* Implement `run-synchronous-process'. Reimplement `shell-command'
and `shell-command-region' in terms of this new procedure.
* Implement `insert-region', which copies text directly from one
buffer to another without making an intermediate copy.
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autosv.scm,v 1.24 1991/04/13 03:58:23 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autosv.scm,v 1.25 1991/04/21 00:48:49 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(set-buffer-auto-save-pathname! buffer false))
(define (delete-auto-save-file! buffer)
- (if (ref-variable delete-auto-save-files)
- (let ((pathname (buffer-auto-save-pathname buffer)))
- (if (and pathname (file-exists? pathname))
- (delete-file pathname)))))
+ (and (ref-variable delete-auto-save-files)
+ (let ((auto-save-pathname (buffer-auto-save-pathname buffer)))
+ (and auto-save-pathname
+ (not (let ((pathname (buffer-pathname buffer)))
+ (and pathname
+ (pathname=? auto-save-pathname pathname))))
+ (catch-file-errors (lambda () false)
+ (lambda ()
+ (delete-file auto-save-pathname)
+ true))))))
(define (rename-auto-save-file! buffer)
(let ((old-pathname (buffer-auto-save-pathname buffer)))
(if (and old-pathname
new-pathname
(not (pathname=? new-pathname old-pathname))
- (not (pathname=? new-pathname (buffer-pathname buffer)))
+ (not (let ((pathname (buffer-pathname buffer)))
+ (and pathname
+ (or (pathname=? new-pathname pathname)
+ (pathname=? old-pathname pathname)))))
(file-exists? old-pathname))
(rename-file old-pathname new-pathname)))))
(append-message "done")))))
(define (auto-save-buffer buffer)
- (region->file (buffer-unclipped-region buffer)
- (buffer-auto-save-pathname buffer))
+ (write-region (buffer-unclipped-region buffer)
+ (buffer-auto-save-pathname buffer)
+ false)
(set-buffer-save-length! buffer)
(set-buffer-auto-saved! buffer))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.141 1991/04/12 23:16:28 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.142 1991/04/21 00:48:54 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
truename
alist
local-bindings
+ local-bindings-installed?
initializations
auto-save-pathname
auto-save-state
(vector-set! buffer buffer-index:truename false)
(vector-set! buffer buffer-index:alist '())
(vector-set! buffer buffer-index:local-bindings '())
+ (vector-set! buffer buffer-index:local-bindings-installed? false)
(vector-set! buffer
buffer-index:initializations
(list (mode-initialization mode)))
\f
;;;; Local Bindings
-(define (make-local-binding! variable new-value)
+(define (define-variable-local-value! buffer variable value)
+ (check-variable-value-validity! variable value)
(without-interrupts
(lambda ()
- (let ((buffer (current-buffer)))
- (let ((bindings (buffer-local-bindings buffer)))
- (let ((binding (assq variable bindings)))
- (if (not binding)
+ (let ((binding (search-local-bindings buffer variable)))
+ (if (buffer-local-bindings-installed? buffer)
+ (begin
+ (if (not binding)
+ (vector-set! buffer
+ buffer-index:local-bindings
+ (cons (cons variable (variable-value variable))
+ (buffer-local-bindings buffer))))
+ (%set-variable-value! variable value))
+ (if binding
+ (set-cdr! binding value)
(vector-set! buffer
buffer-index:local-bindings
- (cons (cons variable (variable-value variable))
- bindings))))))
- (check-variable-value-validity! variable new-value)
- (%set-variable-value! variable new-value)
- (invoke-variable-assignment-daemons! variable))))
+ (cons (cons variable value)
+ (buffer-local-bindings buffer)))))))))
-(define (unmake-local-binding! variable)
+(define (undefine-variable-local-value! buffer variable)
(without-interrupts
(lambda ()
- (let ((buffer (current-buffer)))
- (let ((bindings (buffer-local-bindings buffer)))
- (let ((binding (assq variable bindings)))
- (if binding
- (begin
- (%set-variable-value! variable (cdr binding))
- (vector-set! buffer
- buffer-index:local-bindings
- (delq! binding bindings))
- (invoke-variable-assignment-daemons! variable)))))))))
+ (let ((binding (search-local-bindings buffer variable)))
+ (if binding
+ (begin
+ (vector-set! buffer
+ buffer-index:local-bindings
+ (delq! binding (buffer-local-bindings buffer)))
+ (if (buffer-local-bindings-installed? buffer)
+ (%set-variable-value! variable (cdr binding)))))))))
+
+(define (variable-local-value buffer variable)
+ (let ((binding
+ (and (not (buffer-local-bindings-installed? buffer))
+ (search-local-bindings buffer variable))))
+ (if binding
+ (cdr binding)
+ (variable-value variable))))
+
+(define (set-variable-local-value! buffer variable value)
+ (if (variable-buffer-local? variable)
+ (define-variable-local-value! buffer variable value)
+ (begin
+ (check-variable-value-validity! variable value)
+ (without-interrupts
+ (lambda ()
+ (let ((binding
+ (and (not (buffer-local-bindings-installed? buffer))
+ (search-local-bindings buffer variable))))
+ (if binding
+ (set-cdr! binding value)
+ (%set-variable-value! variable value))))))))
+
+(define (variable-default-value variable)
+ (let ((binding (search-local-bindings (current-buffer) variable)))
+ (if binding
+ (cdr binding)
+ (variable-value variable))))
+
+(define (set-variable-default-value! variable value)
+ (check-variable-value-validity! variable value)
+ (without-interrupts
+ (lambda ()
+ (let ((binding (search-local-bindings (current-buffer) variable)))
+ (if binding
+ (set-cdr! binding value)
+ (%set-variable-value! variable value))))))
+(define-integrable (search-local-bindings buffer variable)
+ (let loop ((bindings (buffer-local-bindings buffer)))
+ (and (not (null? bindings))
+ (if (eq? (caar bindings) variable)
+ (car bindings)
+ (loop (cdr bindings))))))
+\f
(define (undo-local-bindings!)
;; Caller guarantees that interrupts are disabled.
(let ((buffer (current-buffer)))
(let ((bindings (buffer-local-bindings buffer)))
(do ((bindings bindings (cdr bindings)))
((null? bindings))
- (%set-variable-value! (caar bindings) (cdar bindings)))
+ (%%set-variable-value! (caar bindings) (cdar bindings)))
(vector-set! buffer buffer-index:local-bindings '())
(do ((bindings bindings (cdr bindings)))
((null? bindings))
(invoke-variable-assignment-daemons! (caar bindings))))))
-\f
+
(define (with-current-local-bindings! thunk)
(let ((wind-bindings
- (lambda (buffer)
+ (lambda (buffer installed?)
(do ((bindings (buffer-local-bindings buffer) (cdr bindings)))
((null? bindings))
(let ((old-value (variable-value (caar bindings))))
- (%set-variable-value! (caar bindings) (cdar bindings))
- (set-cdr! (car bindings) old-value))))))
- (dynamic-wind (lambda ()
- (let ((buffer (current-buffer)))
- (wind-bindings buffer)
- (perform-buffer-initializations! buffer)))
- thunk
- (lambda ()
- (wind-bindings (current-buffer))))))
+ (%%set-variable-value! (caar bindings) (cdar bindings))
+ (set-cdr! (car bindings) old-value)))
+ (vector-set! buffer
+ buffer-index:local-bindings-installed?
+ installed?))))
+ (dynamic-wind
+ (lambda ()
+ (let ((buffer (current-buffer)))
+ (wind-bindings buffer true)
+ (perform-buffer-initializations! buffer)))
+ thunk
+ (lambda ()
+ (wind-bindings (current-buffer) false)))))
(define (change-local-bindings! old-buffer new-buffer select-buffer!)
;; Assumes that interrupts are disabled and that OLD-BUFFER is selected.
(do ((bindings (buffer-local-bindings old-buffer) (cdr bindings)))
((null? bindings))
(let ((old-value (variable-value (caar bindings))))
- (%set-variable-value! (caar bindings) (cdar bindings))
+ (%%set-variable-value! (caar bindings) (cdar bindings))
(set-cdr! (car bindings) old-value))
(if (not (null? (variable-assignment-daemons (caar bindings))))
(set! variables (cons (caar bindings) variables))))
+ (vector-set! old-buffer buffer-index:local-bindings-installed? false)
(select-buffer!)
(do ((bindings (buffer-local-bindings new-buffer) (cdr bindings)))
((null? bindings))
(let ((old-value (variable-value (caar bindings))))
- (%set-variable-value! (caar bindings) (cdar bindings))
+ (%%set-variable-value! (caar bindings) (cdar bindings))
(set-cdr! (car bindings) old-value))
(if (and (not (null? (variable-assignment-daemons (caar bindings))))
(not (let loop ((variables variables))
(or (eq? (caar bindings) (car variables))
(loop (cdr variables)))))))
(set! variables (cons (caar bindings) variables))))
+ (vector-set! new-buffer buffer-index:local-bindings-installed? true)
(perform-buffer-initializations! new-buffer)
(if (not (null? variables))
(do ((variables variables (cdr variables)))
((null? variables))
(invoke-variable-assignment-daemons! (car variables))))))
\f
-(define (define-variable-local-value! buffer variable value)
- (if (current-buffer? buffer)
- (make-local-binding! variable value)
- (without-interrupts
- (lambda ()
- (let ((binding (search-local-bindings buffer variable)))
- (if binding
- (set-cdr! binding value)
- (vector-set! buffer
- buffer-index:local-bindings
- (cons (cons variable value)
- (buffer-local-bindings buffer)))))))))
-
-(define (variable-local-value buffer variable)
- (if (or (not (within-editor?))
- (current-buffer? buffer))
- (variable-value variable)
- (let ((binding (search-local-bindings buffer variable)))
- (if binding
- (cdr binding)
- (variable-default-value variable)))))
-
-(define (set-variable-local-value! buffer variable value)
- (if (current-buffer? buffer)
- (set-variable-value! variable value)
- (let ((binding (search-local-bindings buffer variable)))
- (if binding
- (set-cdr! binding value)
- (set-variable-default-value! variable value)))))
-
-(define (variable-default-value variable)
- (let ((binding (search-local-bindings (current-buffer) variable)))
- (if binding
- (cdr binding)
- (variable-value variable))))
-
-(define (set-variable-default-value! variable value)
- (let ((binding (search-local-bindings (current-buffer) variable)))
- (if binding
- (set-cdr! binding value)
- (without-interrupts
- (lambda ()
- (check-variable-value-validity! variable value)
- (%set-variable-value! variable value)
- (invoke-variable-assignment-daemons! variable))))))
-
-(define (variable-local-value? buffer variable)
- (let loop ((bindings (buffer-local-bindings buffer)))
- (and (not (null? bindings))
- (or (eq? (caar bindings) variable)
- (loop (cdr bindings))))))
-
-(define-integrable (search-local-bindings buffer variable)
- (let loop ((bindings (buffer-local-bindings buffer)))
- (and (not (null? bindings))
- (if (eq? (caar bindings) variable)
- (car bindings)
- (loop (cdr bindings))))))
-\f
;;;; Modes
(define-integrable (buffer-major-mode buffer)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufinp.scm,v 1.3 1990/11/09 08:56:14 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufinp.scm,v 1.4 1991/04/21 00:49:00 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(if (>= current-index end-index)
(make-eof-object port)
(let ((new-index
- (or (%find-next-char-in-set group current-index end-index
- delimiters)
+ (or (group-find-next-char-in-set group current-index end-index
+ delimiters)
end-index)))
(let ((string
(group-extract-string group current-index new-index)))
(if (< current-index end-index)
(set-buffer-input-port-state/current-index!
state
- (or (%find-next-char-in-set (buffer-input-port-state/group state)
- current-index
- end-index
- delimiters)
+ (or (group-find-next-char-in-set
+ (buffer-input-port-state/group state)
+ current-index
+ end-index
+ delimiters)
end-index))))))
(define (operation/print-self state port)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufmnu.scm,v 1.112 1991/04/03 04:03:30 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufmnu.scm,v 1.113 1991/04/21 00:49:05 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(define (buffer-line-name lstart)
(let ((start (mark+ lstart 4)))
- (char-search-forward #\Space start (line-end start 0))
- (extract-string start (re-match-start 0))))
+ (extract-string
+ start
+ (mark-1+ (char-search-forward #\space start (line-end start 0))))))
(define (buffer-menu-mark lstart column)
(guarantee-buffer-line lstart)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/cinden.scm,v 1.4 1991/03/15 23:37:44 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/cinden.scm,v 1.5 1991/04/21 00:49:09 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(char-match-forward #\( container))))
(define (backward-to-noncomment start end)
- (define (loop start)
+ (let loop ((start start))
(let ((mark (whitespace-start start end)))
- (if (match-backward "*/" mark)
- (and (search-backward "/*" (re-match-start 0) end)
- (loop (re-match-start 0)))
- (let ((mark* (indentation-end mark)))
- (cond ((not (char-match-forward #\# mark*)) mark)
- ((mark<= mark* end) mark*)
- (else (loop mark*)))))))
- (loop start))
+ (let ((m (match-backward "*/" mark)))
+ (if m
+ (let ((m (search-backward "/*" m end)))
+ (and m
+ (loop m)))
+ (let ((mark* (indentation-end mark)))
+ (cond ((not (char-match-forward #\# mark*)) mark)
+ ((mark<= mark* end) mark*)
+ (else (loop mark*)))))))))
(define (backward-to-start-of-continued-exp start end)
(let ((mark
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comint.scm,v 1.2 1991/03/27 23:36:34 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comint.scm,v 1.3 1991/04/21 00:49:16 cph Exp $
Copyright (c) 1991 Massachusetts Institute of Technology
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 "\\`\\s *\\'" string))))
+ (not (re-match-string-forward (re-compile-pattern "\\`\\s *\\'" false)
+ false (ref-variable syntax-table) string))))
\f
(define-command comint-previous-input
"Cycle backwards through input history."
(define (comint-history-search string backward?)
(let ((ring (ref-variable comint-input-ring))
- (regexp (re-quote-string string)))
+ (syntax-table (ref-variable syntax-table))
+ (pattern (re-compile-pattern (re-quote-string string) false)))
(let ((size (+ (ring-size ring) 1)))
(let ((start
(command-message-receive comint-input-ring-tag
(cond ((if backward? (>= index size) (< index 0))
(set-command-message! comint-input-ring-tag start)
(editor-failure "Not found"))
- ((re-search-string-forward regexp
+ ((re-search-string-forward pattern
+ false
+ syntax-table
(ring-ref ring (- index 1)))
(set-variable! comint-last-input-match string)
((ref-command comint-previous-input) (- index start)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.65 1991/03/15 23:49:11 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.66 1991/04/21 00:49:23 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(vector-set! variable variable-index:value-validity-test false)
variable))
-(define-integrable (%set-variable-value! variable value)
+(define-integrable (%%set-variable-value! variable value)
(vector-set! variable variable-index:value value))
(define-integrable (make-variable-buffer-local! variable)
(define (->variable object)
(if (variable? object) object (name->variable object)))
+(define-integrable (%set-variable-value! variable value)
+ (%%set-variable-value! variable value)
+ (invoke-variable-assignment-daemons! variable))
+
(define (set-variable-value! variable value)
(if (variable-buffer-local? variable)
- (make-local-binding! variable value)
- (without-interrupts
- (lambda ()
- (check-variable-value-validity! variable value)
- (%set-variable-value! variable value)
- (invoke-variable-assignment-daemons! variable)))))
+ (define-variable-local-value! (current-buffer) variable value)
+ (begin
+ (check-variable-value-validity! variable value)
+ (without-interrupts
+ (lambda ()
+ (%set-variable-value! variable value))))))
(define (with-variable-value! variable new-value thunk)
(let ((old-value))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/debuge.scm,v 1.40 1990/11/02 03:23:28 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/debuge.scm,v 1.41 1991/04/21 00:49:31 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(write-string "Writing file '")
(write-string filename)
(write-string "'")
- (region->file (buffer-region buffer) filename)
+ (write-region (buffer-region buffer) filename false)
(write-string " -- done")
(set-buffer-pathname! buffer pathname)
(set-buffer-truename! buffer truename)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.17 1991/03/22 00:31:17 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.18 1991/04/21 00:49:38 cph Exp $
Copyright (c) 1989-91 Massachusetts Institute of Technology
"rename"
"rgxcmp"
"ring"
- "search"
"simple"
"strpad"
"strtab"
"schmod"
"scrcom"
"screen"
+ "sendmail"
"sercom"
"shell"
"struct"
(sf-edwin "grpops" "struct")
(sf-edwin "regops" "struct")
(sf-edwin "motion" "struct")
+ (sf-edwin "search" "struct")
(sf-edwin "buffer" "comman" "modes")
(sf-edwin "curren" "buffer")
(sf-class "window" "class")
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/dired.scm,v 1.106 1991/04/11 03:12:28 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/dired.scm,v 1.107 1991/04/21 00:49:47 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(string-append "Reading directory "
(pathname->string pathname)
"..."))
- (with-working-directory-pathname (pathname-directory-path pathname)
- (lambda ()
- (shell-command
- (string-append "ls "
- (ref-variable dired-listing-switches)
- " "
- (if (file-directory? pathname)
- (pathname->string pathname)
- (pathname-name-path pathname)))
- (buffer-point buffer))))
+ (let ((directory (pathname-directory-path pathname)))
+ (with-working-directory-pathname directory
+ (lambda ()
+ (run-synchronous-process false
+ (buffer-point buffer)
+ (find-program "ls" directory)
+ (ref-variable dired-listing-switches)
+ (if (file-directory? pathname)
+ (pathname->string pathname)
+ (pathname-name-path pathname))))))
(append-message "done")
(let ((point (mark-left-inserting-copy (buffer-point buffer)))
(group (buffer-group buffer)))
(set-buffer-read-only! buffer))
(define (add-dired-entry pathname)
- (let ((lstart (line-start (current-point) 0)))
- (if (pathname=? (buffer-default-directory (mark-buffer lstart))
- (pathname-directory-path pathname))
+ (let ((lstart (line-start (current-point) 0))
+ (directory (pathname-directory-path pathname)))
+ (if (pathname=? (buffer-default-directory (mark-buffer lstart)) directory)
(let ((start (mark-right-inserting lstart)))
- (shell-command
- (string-append "ls -d "
- (ref-variable dired-listing-switches)
- " "
- (pathname->string pathname))
- lstart)
+ (run-synchronous-process false
+ lstart
+ (find-program "ls" directory)
+ "-d"
+ (ref-variable dired-listing-switches)
+ (pathname->string pathname))
(insert-string " " start)
- (let ((start
- (mark-right-inserting (dired-filename-start start))))
+ (let ((start (mark-right-inserting (dired-filename-start start))))
(insert-string
(pathname-name-string
(string->pathname
(define-command dired-chmod
"Change mode of this file."
"sChange to Mode"
- (lambda (mode)
- (let ((pathname (dired-current-pathname)))
- (subprocess-wait
- (start-batch-subprocess
- (find-program "chmod" (buffer-default-directory (current-buffer)))
- (vector "chmod" mode (pathname->string pathname))
- false))
- (dired-redisplay pathname))))
+ (lambda (mode) (dired-change-line "chmod" mode)))
(define-command dired-chgrp
"Change group of this file."
"sChange to Group"
- (lambda (group)
- (let ((pathname (dired-current-pathname)))
- (subprocess-wait
- (start-batch-subprocess
- (find-program "chgrp" (buffer-default-directory (current-buffer)))
- (vector "chgrp" group (pathname->string pathname))
- false))
- (dired-redisplay pathname))))
+ (lambda (group) (dired-change-line "chgrp" group)))
(define-command dired-chown
"Change owner of this file."
"sChange to Owner"
- (lambda (owner)
- (let ((pathname (dired-current-pathname)))
- (subprocess-wait
- (start-batch-subprocess
- (find-program "chown" (buffer-default-directory (current-buffer)))
- (vector "chown" owner (pathname->string pathname))
- false))
- (dired-redisplay pathname))))
+ (lambda (owner) (dired-change-line "chown" owner)))
+
+(define (dired-change-line program argument)
+ (let ((pathname (dired-current-pathname)))
+ (run-synchronous-process false
+ false
+ (find-program program
+ (pathname-directory-path pathname))
+ argument
+ (pathname->string pathname))
+ (dired-redisplay pathname)))
(define (dired-redisplay pathname)
(let ((lstart (mark-right-inserting (line-start (current-point) 0))))
edwin-syntax-table)
("search" (edwin)
syntax-table/system-internal)
+ ("sendmail" (edwin sendmail)
+ edwin-syntax-table)
("sercom" (edwin)
edwin-syntax-table)
("shell" (edwin)
;;; -*-Scheme-*-
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.13 1991/03/22 00:31:28 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.14 1991/04/21 00:50:02 cph Exp $
;;; program to load package contents
;;; **** This program (unlike most .ldr files) is not generated by a program.
(load "regcom" (->environment '(EDWIN REGISTER-COMMAND)))
(load "replaz" environment)
(load "schmod" environment)
+ (load "sendmail" (->environment '(EDWIN SENDMAIL)))
(load "sercom" environment)
(load "iserch" (->environment '(EDWIN INCREMENTAL-SEARCH)))
(load "shell" environment)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.29 1991/04/12 23:23:58 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.30 1991/04/21 00:50:10 cph Exp $
Copyright (c) 1989-91 Massachusetts Institute of Technology
(files "regexp")
(parent (edwin))
(export (edwin)
- char-match-backward
- char-match-forward
- char-search-backward
- char-search-forward
- match-backward
- match-forward
+ delete-match
+ re-match-buffer-forward
re-match-end
re-match-end-index
re-match-forward
re-match-start
re-match-start-index
re-match-string-forward
- re-match-string-forward-ci
re-match-substring-forward
- re-match-substring-forward-ci
- re-quote-string
re-search-backward
+ re-search-buffer-backward
+ re-search-buffer-forward
re-search-forward
+ re-search-string-backward
re-search-string-forward
- re-search-string-forward-ci
+ re-search-substring-backward
re-search-substring-forward
- re-search-substring-forward-ci
+ replace-match
search-backward
- search-forward
- skip-chars-backward
- skip-chars-forward))
+ search-forward))
(define-package (edwin regular-expression-compiler)
(files "rgxcmp")
re-compile-pattern
re-compile-string
re-disassemble-pattern
+ re-quote-string
re-translation-table))
(define-package (edwin lisp-indentation)
shell-command
shell-command-region
start-process
- stop-process))
\ No newline at end of file
+ stop-process
+ run-synchronous-process))
+
+(define-package (edwin sendmail)
+ (files "sendmail")
+ (parent (edwin))
+ (export (edwin)
+ edwin-mode$mail
+ edwin-variable$mail-archive-file-name
+ edwin-variable$mail-default-reply-to
+ edwin-variable$mail-header-separator
+ edwin-variable$mail-interactive
+ edwin-variable$mail-mode-hook
+ edwin-variable$mail-reply-buffer
+ edwin-variable$mail-self-blind
+ edwin-variable$mail-yank-ignored-headers
+ edwin-variable$send-mail-procedure
+ edwin-variable$sendmail-program
+ make-mail-buffer))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.148 1991/04/12 23:26:32 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.149 1991/04/21 00:50:21 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(buffer-modified! buffer)))
(define-command write-file
- "Store buffer in specified file.
-This file becomes the one being visited."
+ "Write current buffer into file FILENAME.
+Makes buffer visit that file, and marks it not modified."
"FWrite file"
(lambda (filename)
(write-file (current-buffer) filename)))
(define (write-file buffer filename)
- (set-visited-pathname buffer (->pathname filename))
- (write-buffer-interactive buffer))
+ (if (and filename
+ (not (string-null? filename)))
+ (set-visited-pathname buffer (->pathname filename)))
+ (buffer-modified! buffer)
+ (save-buffer buffer))
(define-command write-region
- "Store the region in specified file."
- "FWrite region"
- (lambda (filename)
- (write-region (current-region) filename)))
+ "Write current region into specified file."
+ "r\nFWrite region to file"
+ (lambda (region filename)
+ (write-region region filename true)))
+
+(define-command append-to-file
+ "Write current region into specified file."
+ "r\nFAppend to file"
+ (lambda (region filename)
+ (append-to-file region filename true)))
(define-command insert-file
"Insert contents of file into existing text.
Leaves point at the beginning, mark at the end."
"FInsert file"
(lambda (filename)
- (set-current-region! (insert-file (current-point) filename))))
-
+ (let ((point (mark-right-inserting (current-point))))
+ (let ((mark (mark-left-inserting point)))
+ (insert-file point filename)
+ (set-current-point! point)
+ (push-current-mark! mark)))))
+\f
(define (pathname->buffer-name pathname)
(let ((name (pathname-name pathname)))
(if name
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.95 1991/04/12 23:28:01 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.96 1991/04/21 00:50:30 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(initialize-buffer-local-variables! buffer))
(define (insert-file mark filename)
- (let ((pathname (->pathname filename)))
- (let ((truename (pathname->input-truename pathname)))
- (if truename
- (%insert-file mark truename)
- (editor-error "File " (pathname->string pathname) " not found")))))
+ (%insert-file
+ mark
+ (let ((pathname (->pathname filename)))
+ (let ((truename (pathname->input-truename pathname)))
+ (if (not truename)
+ (editor-error "File " (pathname->string pathname) " not found"))
+ truename))))
(define-variable read-file-message
"If true, messages are displayed when files are read into the editor."
(editor-error
"Local variables entry is missing the prefix"))
start))))
- (let ((m2 (if (char-search-forward #\: m1 end)
- (re-match-start 0)
- (editor-error
- "Missing colon in local variables entry"))))
+ (let ((m2
+ (let ((m2 (char-search-forward #\: m1 end)))
+ (if (not m2)
+ (editor-error "Missing colon in local variables entry"))
+ (mark-1+ m2))))
(let ((var (extract-string m1 (horizontal-space-start m2)))
(m3 (horizontal-space-end (mark1+ m2))))
(if (not (string-ci=? var "End"))
(let ((variable (name->variable var))
(value (evaluate val)))
(lambda ()
- (make-local-binding! variable
- value))))))))))
+ (define-variable-local-value!
+ (current-buffer)
+ variable
+ value))))))))))
(loop m4))))))))
(loop start))))
(define (write-buffer buffer)
(let ((truename
- (write-region (buffer-unclipped-region buffer)
- (buffer-pathname buffer))))
+ (string->pathname
+ (write-region (buffer-unclipped-region buffer)
+ (buffer-pathname buffer)
+ true))))
(if truename
(begin
(set-buffer-truename! buffer truename)
(buffer-not-modified! buffer)
(set-buffer-modification-time! buffer
(file-modification-time truename))))))
-
-(define (write-region region filename)
- (let ((truename (pathname->output-truename (->pathname filename))))
- (temporary-message "Writing file \"" (pathname->string truename) "\"")
- (region->file region truename)
- (append-message " -- done")
- truename))
-
-(define (region->file region pathname)
- (call-with-output-file pathname
- (lambda (port)
- (write-string (region->string region) port))))
+\f
+(define-variable enable-emacs-write-file-message
+ "If true, generate Emacs-style message when writing files."
+ true
+ boolean?)
+
+(define (write-region region filename message?)
+ (let ((filename (canonicalize-output-filename filename)))
+ (let ((do-it
+ (lambda ()
+ (group-write-to-file (region-group region)
+ (region-start-index region)
+ (region-end-index region)
+ filename))))
+ (cond ((not message?)
+ (do-it))
+ ((ref-variable enable-emacs-write-file-message)
+ (do-it)
+ (message "Wrote " filename))
+ (else
+ (temporary-message "Writing file \"" filename "\"")
+ (do-it)
+ (append-message " -- done"))))
+ filename))
+
+(define (append-to-file region filename message?)
+ (let ((filename (canonicalize-overwrite-filename filename)))
+ (let ((do-it
+ (lambda ()
+ (group-append-to-file (region-group region)
+ (region-start-index region)
+ (region-end-index region)
+ filename))))
+ (cond ((not message?)
+ (do-it))
+ ((ref-variable enable-emacs-write-file-message)
+ (do-it)
+ (message "Wrote " filename))
+ (else
+ (temporary-message "Writing file \"" filename "\"")
+ (do-it)
+ (append-message " -- done"))))
+ filename))
+
+(define (group-write-to-file group start end filename)
+ (let ((channel (file-open-output-channel filename)))
+ (group-write-to-channel group start end channel)
+ (channel-close channel)))
+
+(define (group-append-to-file group start end filename)
+ (let ((channel (file-open-append-channel filename)))
+ (group-write-to-channel group start end channel)
+ (channel-close channel)))
+
+(define (group-write-to-channel group start end channel)
+ (let ((text (group-text group))
+ (gap-start (group-gap-start group))
+ (gap-end (group-gap-end group))
+ (gap-length (group-gap-length group)))
+ (cond ((fix:<= end gap-start)
+ (channel-write-block channel text start end))
+ ((fix:<= gap-start start)
+ (channel-write-block channel
+ text
+ (fix:+ start gap-length)
+ (fix:+ end gap-length)))
+ (else
+ (channel-write-block channel text start gap-start)
+ (channel-write-block channel
+ text
+ gap-end
+ (fix:+ end gap-length))))))
\f
(define (require-newline buffer)
(let ((require-final-newline? (ref-variable require-final-newline)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fill.scm,v 1.46 1991/04/13 04:00:31 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fill.scm,v 1.47 1991/04/21 00:50:39 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(let ((end (match-forward fill-prefix point)))
(if end
(delete-string point end))))
- (if (char-search-forward #\newline point)
- (begin
- (move-mark-to! point (re-match-start 0))
- (delete-string point (mark1+ point))
- (insert-char #\space point)
- (loop))))
+ (let ((m (char-search-forward #\newline point end)))
+ (if m
+ (begin
+ (move-mark-to! point m)
+ (delete-left-char point)
+ (insert-char #\space point)
+ (loop)))))
(delete-horizontal-space end)
(move-mark-to! point start)
(let loop ()
(let ((target (move-to-column point fill-column)))
(if (not (group-end? target))
(let ((end
- (cond ((char-search-backward #\space
+ (let ((end
+ (char-search-backward #\space
(mark1+ target)
- point)
- (re-match-end 0))
- ((char-search-forward #\space target)
- (re-match-start 0))
- (else false))))
+ point)))
+ (if end
+ (mark1+ end)
+ (let ((m
+ (char-search-forward #\space
+ target
+ end)))
+ (and m
+ (mark-1+ m)))))))
(if end
(begin
(move-mark-to! point end)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.95 1991/04/12 23:28:16 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.96 1991/04/21 00:50:46 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(let ((variable (name->variable variable)))
(if (not (variable-value-valid? variable value))
(editor-error "illegal value for variable:" value))
- (make-local-binding! variable value))))
+ (define-variable-local-value! (current-buffer) variable value))))
(define-command kill-local-variable
"Make a variable use its global value in the current buffer."
"vKill local variable"
(lambda (name)
- (unmake-local-binding! (name->variable name))))
+ (undefine-variable-local-value! (current-buffer) (name->variable name))))
\f
;;;; Other Stuff
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/info.scm,v 1.98 1991/04/12 23:28:31 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/info.scm,v 1.99 1991/04/21 00:50:55 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(define (menu-item-keyword item)
(let ((end (char-search-forward #\: item (line-end item 0))))
- (if end
- (extract-string item (re-match-start 0))
- (error "Menu item missing colon"))))
+ (if (not end)
+ (error "Menu item missing colon"))
+ (extract-string item (mark-1+ end))))
(define (menu-item-name item)
(let ((colon (char-search-forward #\: item (line-end item 0))))
- (cond ((not colon) (error "Menu item missing colon"))
- ((match-forward "::" (re-match-start 0))
- (extract-string item (re-match-start 0)))
- (else
- (%menu-item-name (horizontal-space-end colon))))))
+ (if (not colon)
+ (error "Menu item missing colon."))
+ (if (match-forward "::" (mark-1+ colon))
+ (extract-string item (re-match-start 0))
+ (%menu-item-name (horizontal-space-end colon)))))
(define (%menu-item-name start)
(if (line-end? start)
- (error "Menu item missing node name")
- (extract-string start
- (let ((end (line-end start 0)))
- (if (re-search-forward "[.,\t]" start end)
- (re-match-start 0)
- end)))))
+ (error "Menu item missing node name"))
+ (extract-string start
+ (let ((end (line-end start 0)))
+ (if (re-search-forward "[.,\t]" start end)
+ (re-match-start 0)
+ end))))
\f
;;;; Cross References
(re-search-forward "\\*Note[ \t\n]*" start))
(define (cref-item-keyword item)
- (let ((colon (char-search-forward #\: item)))
- (if colon
- (%cref-item-keyword item (re-match-start 0))
- (error "Cross reference missing colon"))))
+ (let ((colon (char-search-forward #\: item (group-end item))))
+ (if (not colon)
+ (error "Cross reference missing colon."))
+ (%cref-item-keyword item (mark-1+ colon))))
(define (%cref-item-keyword item colon)
(let ((string (extract-string item colon)))
(string-trim string)))
(define (cref-item-name item)
- (let ((colon (char-search-forward #\: item)))
- (cond ((not colon) (error "Cross reference missing colon"))
- ((match-forward "::" (re-match-start 0))
- (%cref-item-keyword item (re-match-start 0)))
- (else
- (%menu-item-name (cref-item-space-end colon))))))
+ (let ((colon (char-search-forward #\: item (group-end item))))
+ (if (not colon)
+ (error "Cross reference missing colon."))
+ (if (match-forward "::" (mark-1+ colon))
+ (%cref-item-keyword item (re-match-start 0))
+ (%menu-item-name (cref-item-space-end colon)))))
(define (cref-item-space-end mark)
(skip-chars-forward " \t\n" mark))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kilcom.scm,v 1.59 1991/03/22 00:32:08 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kilcom.scm,v 1.60 1991/04/21 00:51:04 cph Exp $
;;;
;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
"P"
(lambda (argument)
(define (back n)
- (let ((m1 (mark- (current-point) n 'LIMIT)))
- (if (not (char-search-backward #\Tab (current-point) m1))
- m1
- (begin (convert-tab-to-spaces! (re-match-start 0))
- (back n)))))
+ (let ((point (current-point)))
+ (let ((m1 (mark- point n 'LIMIT)))
+ (let ((tab (char-search-backward #\tab point m1)))
+ (if (not tab)
+ m1
+ (begin
+ (convert-tab-to-spaces! tab)
+ (back n)))))))
(define (forth n)
- (let ((m1 (mark+ (current-point) n 'LIMIT)))
- (if (not (char-search-forward #\Tab (current-point) m1))
- m1
- (begin (convert-tab-to-spaces! (re-match-start 0))
- (forth n)))))
+ (let ((point (current-point)))
+ (let ((m1 (mark+ point n 'LIMIT)))
+ (let ((tab (char-search-forward #\tab point m1)))
+ (if (not tab)
+ m1
+ (begin
+ (convert-tab-to-spaces! (mark-1+ tab))
+ (forth n)))))))
(cond ((not argument)
- (if (char-match-backward #\Tab)
- (convert-tab-to-spaces! (mark-1+ (current-point))))
+ (let ((point (current-point)))
+ (if (char-match-backward #\Tab point)
+ (convert-tab-to-spaces! (mark-1+ point))))
(delete-region (mark-1+ (current-point))))
((positive? argument)
(kill-region (back argument)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/lincom.scm,v 1.107 1991/04/12 23:20:06 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/lincom.scm,v 1.108 1991/04/21 00:51:10 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(lambda (argument)
(let ((indent-line-procedure (ref-variable indent-line-procedure)))
(if (eq? indent-line-procedure indent-to-left-margin)
- (insert-chars #\Tab argument)
+ (insert-chars #\tab argument)
(indent-line-procedure)))))
(define-command newline-and-indent
((ref-command newline) false)
((ref-command indent-according-to-mode))))
\f
+(define-variable indent-tabs-mode
+ "If false, do not use tabs for indentation or horizontal spacing."
+ true
+ boolean?)
+
+(define-command indent-tabs-mode
+ "Enables or disables use of tabs as indentation.
+A positive argument turns use of tabs on;
+zero or negative, turns it off.
+With no argument, the mode is toggled."
+ "P"
+ (lambda (argument)
+ (set-variable! indent-tabs-mode
+ (if argument
+ (positive? argument)
+ (not (ref-variable indent-tabs-mode))))))
+
+(define-command insert-tab
+ "Insert a tab character."
+ ()
+ (lambda ()
+ (if (ref-variable indent-tabs-mode)
+ (insert-char #\tab)
+ (maybe-change-column
+ (let ((tab-width (ref-variable tab-width)))
+ (* tab-width (1+ (quotient (current-column) tab-width))))))))
+
+(define-command indent-relative
+ "Space out to under next indent point in previous nonblank line.
+An indent point is a non-whitespace character following whitespace."
+ ()
+ (lambda ()
+ (let ((point (current-point)))
+ (let ((indentation (indentation-of-previous-non-blank-line point)))
+ (cond ((not (= indentation (current-indentation point)))
+ (change-indentation indentation point))
+ ((line-start? (horizontal-space-start point))
+ (set-current-point! (horizontal-space-end point))))))))
+
+(define (indentation-of-previous-non-blank-line mark)
+ (let ((start (find-previous-non-blank-line mark)))
+ (if start
+ (current-indentation start)
+ 0)))
+\f
+(define-variable indent-region-procedure
+ "Function which is short cut to indent each line in region with Tab.
+#F means really call Tab on each line."
+ false
+ (lambda (object)
+ (or (false? object)
+ (and (procedure? object)
+ (procedure-arity-valid? object 2)))))
+
+(define-command indent-region
+ "Indent each nonblank line in the region.
+With no argument, indent each line with Tab.
+With argument COLUMN, indent each line to that column."
+ "r\nP"
+ (lambda (region argument)
+ (let ((start (region-start region))
+ (end (region-end region)))
+ (cond (argument
+ (indent-region start end argument))
+ ((ref-variable indent-region-procedure)
+ ((ref-variable indent-region-procedure) start end))
+ (else
+ (for-each-line-in-region start end
+ (let ((indent-line (ref-variable indent-line-procedure)))
+ (lambda (start)
+ (set-current-point! start)
+ (indent-line)))))))))
+
+(define (indent-region start end n-columns)
+ (if (exact-nonnegative-integer? n-columns)
+ (for-each-line-in-region start end
+ (lambda (start)
+ (delete-string start (horizontal-space-end start))
+ (insert-horizontal-space n-columns start)))))
+
+(define-command indent-rigidly
+ "Indent all lines starting in the region sideways by ARG columns."
+ "r\nP"
+ (lambda (region argument)
+ (if argument
+ (indent-rigidly (region-start region) (region-end region) argument))))
+
+(define (indent-rigidly start end n-columns)
+ (for-each-line-in-region start end
+ (lambda (start)
+ (let ((end (horizontal-space-end start)))
+ (if (line-end? end)
+ (delete-string start end)
+ (let ((new-column (max 0 (+ n-columns (mark-column end)))))
+ (delete-string start end)
+ (insert-horizontal-space new-column start)))))))
+
+(define (for-each-line-in-region start end procedure)
+ (if (not (mark<= start end))
+ (error "Marks incorrectly related:" start end))
+ (let ((start (mark-right-inserting-copy (line-start start 0))))
+ (let ((end
+ (mark-left-inserting-copy
+ (if (and (line-start? end) (mark< start end))
+ (mark-1+ end)
+ (line-end end 0)))))
+ (let loop ()
+ (procedure start)
+ (let ((m (line-end start 0)))
+ (if (mark< m end)
+ (begin
+ (move-mark-to! start (mark1+ m))
+ (loop)))))
+ (mark-temporary! start)
+ (mark-temporary! end))))
+\f
(define-command newline
"Insert newline, or move onto blank line.
A blank line is one containing only spaces and tabs
"\\[delete-indentation] won't insert a space to the left of these."
(char-set #\)))
\f
-(define-variable indent-tabs-mode
- "If false, do not use tabs for indentation or horizontal spacing."
- true)
-
-(define-command indent-tabs-mode
- "Enables or disables use of tabs as indentation.
-A positive argument turns use of tabs on;
-zero or negative, turns it off.
-With no argument, the mode is toggled."
- "P"
- (lambda (argument)
- (set-variable! indent-tabs-mode
- (if argument
- (positive? argument)
- (not (ref-variable indent-tabs-mode))))))
-
-(define-command insert-tab
- "Insert a tab character."
- ()
- (lambda ()
- (if (ref-variable indent-tabs-mode)
- (insert-char #\Tab)
- (maybe-change-column
- (let ((tab-width (ref-variable tab-width)))
- (* tab-width (1+ (quotient (current-column) tab-width))))))))
-
-(define-command indent-region
- "Indent all lines between point and mark.
-With argument, indents each line to exactly that column.
-Otherwise, does Tab on each line.
-A line is processed if its first character is in the region.
-The mark is left after the last line processed."
- "P"
- (lambda (argument)
- (cond ((not argument)
- (not-implemented))
- ((not (negative? argument))
- (current-region-of-lines
- (lambda (start end)
- (let loop ((mark start))
- (change-indentation argument mark)
- (if (not (mark= mark end))
- (loop (mark-right-inserting (line-start mark 1)))))))))))
-\f
-(define-command indent-rigidly
- "Shift text in region sideways as a unit.
-All the lines in the region (first character between point and mark)
-have their indentation incremented by the numeric argument
-of this command (which may be negative).
-Exception: lines containing just spaces and tabs become empty."
- "P"
- (lambda (argument)
- (if argument
- (current-region-of-lines
- (lambda (start end)
- (define (loop mark)
- (if (line-blank? mark)
- (delete-horizontal-space mark)
- (change-indentation
- (max (+ argument (current-indentation mark)) 0)
- mark))
- (if (not (mark= mark end))
- (loop (mark-right-inserting (line-start mark 1)))))
- (loop start))))))
-
-(define (current-region-of-lines receiver)
- (let ((r (current-region)))
- (let ((start (mark-right-inserting (line-start (region-start r) 0))))
- (receiver start
- (if (mark= start (line-start (region-end r) 0))
- start
- (mark-right-inserting
- (line-start (region-end r)
- (if (line-start? (region-end r)) -1 0))))))))
-
-(define (untabify-region region)
- (let ((end (region-end region)))
- (let loop ((start (region-start region)))
- (if (char-search-forward #\Tab start end)
- (let ((tab (re-match-start 0))
- (next (mark-left-inserting (re-match-end 0))))
- (let ((n-spaces (- (mark-column next) (mark-column tab))))
- (delete-string tab next)
- (insert-chars #\Space n-spaces next))
- (loop next))))))
+;;;; Tabification
(define-command untabify
"Convert all tabs in region to multiple spaces, preserving columns.
The variable tab-width controls the action."
"r"
- untabify-region)
+ (lambda (region)
+ (untabify-region (region-start region) (region-end region))))
+
+(define (untabify-region start end)
+ (let ((start (mark-right-inserting-copy start))
+ (end (mark-left-inserting-copy end)))
+ (do ()
+ ((not (char-search-forward #\tab start end)))
+ (let ((tab (re-match-start 0)))
+ (move-mark-to! start (re-match-end 0))
+ (let ((n-spaces (- (mark-column start) (mark-column tab))))
+ (delete-string tab start)
+ (insert-chars #\space n-spaces start))))
+ (mark-temporary! start)
+ (mark-temporary! end)))
(define-command tabify
"Convert multiple spaces in region to tabs when possible.
A group of spaces is partially replaced by tabs
when this can be done without changing the column they end at.
The variable tab-width controls the action."
- ()
- (lambda ()
- (not-implemented)))
-
-(define-command indent-relative
- "Space out to under next indent point in previous nonblank line.
-An indent point is a non-whitespace character following whitespace."
- ()
- (lambda ()
- (let ((point (current-point)))
- (let ((indentation (indentation-of-previous-non-blank-line point)))
- (cond ((not (= indentation (current-indentation point)))
- (change-indentation indentation point))
- ((line-start? (horizontal-space-start point))
- (set-current-point! (horizontal-space-end point))))))))
-
-(define (indentation-of-previous-non-blank-line mark)
- (let ((start (find-previous-non-blank-line mark)))
- (if start (current-indentation start) 0)))
\ No newline at end of file
+ "r"
+ (lambda (region)
+ (tabify-region (region-start region) (region-end region))))
+
+(define (tabify-region start end)
+ (let ((start (mark-left-inserting-copy start))
+ (end (mark-left-inserting-copy end))
+ (pattern (re-compile-pattern "[ \t][ \t]+" false))
+ (tab-width (group-tab-width (mark-group start))))
+ (do ()
+ ((not (re-search-buffer-forward pattern false false
+ (mark-group start)
+ (mark-index start)
+ (mark-index end))))
+ (move-mark-to! start (re-match-start 0))
+ (let ((end-column (mark-column (re-match-end 0))))
+ (delete-string start (re-match-end 0))
+ (insert-horizontal-space end-column start tab-width)))
+ (mark-temporary! start)
+ (mark-temporary! end)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/macros.scm,v 1.50 1991/03/15 23:26:19 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/macros.scm,v 1.51 1991/04/21 00:51:18 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(syntax-table-define edwin-syntax-table 'LOCAL-SET-VARIABLE!
(lambda (name #!optional value)
- `(MAKE-LOCAL-BINDING!
+ `(DEFINE-VARIABLE-LOCAL-VALUE!
+ (CURRENT-BUFFER)
,(variable-name->scheme-name (canonicalize-name name))
,(if (default-object? value) '#F value))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.34 1991/04/12 23:29:11 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.35 1991/04/21 00:51:24 cph Exp $
Copyright (c) 1989-91 Massachusetts Institute of Technology
(declare (usual-integrations))
(package/system-loader "edwin" '() 'QUERY)
-(add-system! (make-system "Edwin" 3 34 '()))
\ No newline at end of file
+(add-system! (make-system "Edwin" 3 35 '()))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.123 1990/10/03 04:55:37 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.124 1991/04/21 00:51:28 cph Exp $
;;;
-;;; Copyright (c) 1985, 1989, 1990 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define-key 'fundamental '(#\c-x #\4 #\b) 'switch-to-buffer-other-window)
(define-key 'fundamental '(#\c-x #\4 #\d) 'dired-other-window)
(define-key 'fundamental '(#\c-x #\4 #\f) 'find-file-other-window)
+(define-key 'fundamental '(#\c-x #\4 #\m) 'mail-other-window)
(define-key 'fundamental '(#\c-x #\5) 'split-window-horizontally)
(define-key 'fundamental '(#\c-x #\;) 'set-comment-column)
(define-key 'fundamental '(#\c-x #\=) 'what-cursor-position)
(define-key 'fundamental '(#\c-x #\j) 'register-to-point)
(define-key 'fundamental '(#\c-x #\k) 'kill-buffer)
(define-key 'fundamental '(#\c-x #\l) 'count-lines-page)
+(define-key 'fundamental '(#\c-x #\m) 'mail)
(define-key 'fundamental '(#\c-x #\n) 'narrow-to-region)
(define-key 'fundamental '(#\c-x #\o) 'other-window)
(define-key 'fundamental '(#\c-x #\p) 'narrow-to-page)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/process.scm,v 1.3 1991/04/11 03:06:39 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/process.scm,v 1.4 1991/04/21 00:51:34 cph Exp $
;;;
;;; Copyright (c) 1991 Massachusetts Institute of Technology
;;;
;;;; Synchronous Subprocesses
(define (shell-command command output-mark)
- (let ((process
- (start-pipe-subprocess "/bin/sh" (vector "sh" "-c" command) false))
- (output-mark (mark-left-inserting output-mark)))
- (channel-close (subprocess-output-channel process))
- (let ((output-channel (subprocess-input-channel process)))
- (channel-nonblocking output-channel)
- (let ((copy-output
- (let ((buffer (make-string 512)))
- (lambda ()
- (let loop ()
- (let ((n (channel-read output-channel buffer 0 512)))
- (if (and n (positive? n))
- (begin
- (insert-substring buffer 0 n output-mark)
- (loop)))))))))
- (let loop ()
- (copy-output)
- (let ((status (subprocess-status process)))
- (if (eq? status 'RUNNING)
- (loop)
- (begin
- (channel-blocking output-channel)
- (copy-output)
- (process-termination-message process
- status
- output-mark)))))))))
-
-(define (process-termination-message process status output-mark)
- (let ((reason (subprocess-exit-reason process)))
- (let ((abnormal-termination
- (lambda (message)
- (guarantee-newlines 2 output-mark)
- (insert-string "Process " output-mark)
- (insert-string message output-mark)
- (insert-string " " output-mark)
- (insert-string (number->string reason) output-mark)
- (insert-string "." output-mark)
- (insert-newline output-mark))))
- (case status
- ((STOPPED)
- (abnormal-termination "stopped with signal")
- (subprocess-kill process)
- (subprocess-wait process))
- ((SIGNALLED)
- (abnormal-termination "terminated with signal"))
- ((EXITED)
- (if (not (eqv? 0 reason))
- (abnormal-termination "exited abnormally with code"))))))
- (subprocess-delete process))
-\f
+ (run-synchronous-process false output-mark "/bin/sh" "-c" command))
+
(define (shell-command-region command output-mark input-region)
+ (run-synchronous-process input-region output-mark "/bin/sh" "-c" command))
+
+(define (run-synchronous-process input-region output-mark program . arguments)
(let ((process
- (start-pipe-subprocess "/bin/sh" (vector "sh" "-c" command) false))
- (output-mark (mark-left-inserting output-mark))
- (group (region-group input-region))
- (start-index (region-start-index input-region))
- (end-index (region-end-index input-region)))
- (let ((input-channel (subprocess-output-channel process))
- (output-channel (subprocess-input-channel process)))
- (channel-nonblocking input-channel)
- (channel-nonblocking output-channel)
- (let ((copy-output
- (let ((buffer (make-string 512)))
- (lambda ()
- (let loop ()
- (let ((n (channel-read output-channel buffer 0 512)))
- (if (and n (positive? n))
- (begin
- (insert-substring buffer 0 n output-mark)
- (loop)))))))))
+ (start-pipe-subprocess program
+ (list->vector
+ (cons (os/filename-non-directory program)
+ arguments))
+ false)))
+ (call-with-output-copier process output-mark
+ (lambda (copy-output)
+ (call-with-input-copier process input-region
+ (lambda (copy-input)
+ (let loop ()
+ (copy-input)
+ (copy-output)
+ (let ((status (subprocess-status process)))
+ (if (eq? status 'RUNNING)
+ (loop)
+ status)))))))))
+\f
+(define (call-with-output-copier process output-mark receiver)
+ (let ((output-mark (and output-mark (mark-left-inserting output-mark))))
+ (let ((status
+ (if output-mark
+ (let ((output-channel (subprocess-input-channel process)))
+ (let ((copy-output
+ (let ((buffer (make-string 512)))
+ (lambda ()
+ (let loop ()
+ (let ((n (channel-read output-channel
+ buffer 0 512)))
+ (if (and n (positive? n))
+ (begin
+ (insert-substring buffer 0 n output-mark)
+ (loop)))))))))
+ (channel-nonblocking output-channel)
+ (let ((status (receiver copy-output)))
+ (channel-blocking output-channel)
+ (copy-output)
+ status)))
+ (receiver (lambda () unspecific)))))
+ (let ((reason (subprocess-exit-reason process)))
+ (let ((abnormal-termination
+ (lambda (message)
+ (if output-mark
+ (begin
+ (guarantee-newlines 2 output-mark)
+ (insert-string "Process " output-mark)
+ (insert-string message output-mark)
+ (insert-string " " output-mark)
+ (insert-string (number->string reason) output-mark)
+ (insert-string "." output-mark)
+ (insert-newline output-mark))))))
+ (case status
+ ((STOPPED)
+ (abnormal-termination "stopped with signal")
+ (subprocess-kill process)
+ (subprocess-wait process))
+ ((SIGNALLED)
+ (abnormal-termination "terminated with signal"))
+ ((EXITED)
+ (if (not (eqv? 0 reason))
+ (abnormal-termination "exited abnormally with code")))))
+ (subprocess-delete process)
+ (cons status reason)))))
+\f
+(define (call-with-input-copier process input-region receiver)
+ (if input-region
+ (let ((group (region-group input-region))
+ (start-index (region-start-index input-region))
+ (end-index (region-end-index input-region))
+ (input-channel (subprocess-output-channel process)))
+ (channel-nonblocking input-channel)
(call-with-current-continuation
(lambda (continuation)
(bind-condition-handler (list condition-type:system-call-error)
(lambda (condition)
- (if (and (eq? 'WRITE
- (access-condition condition 'SYSTEM-CALL))
- (eq? 'BROKEN-PIPE
- (access-condition condition 'ERROR-TYPE)))
- (begin
- (channel-blocking output-channel)
- (copy-output)
- (guarantee-newlines 2 output-mark)
- (insert-string "broken pipe" output-mark)
- (insert-newline output-mark)
- (continuation
- (process-termination-message process
- (subprocess-wait process)
- output-mark)))))
+ (if (and (eq? 'WRITE (system-call-name condition))
+ (eq? 'BROKEN-PIPE (system-call-error condition)))
+ (continuation (subprocess-wait process))))
(lambda ()
- (let loop ()
- (if (< start-index end-index)
- (let ((index (min (+ start-index 512) end-index)))
- (let ((buffer
- (group-extract-string group
- start-index
- index)))
- (let ((n
- (channel-write input-channel
- buffer
- 0
- (string-length buffer))))
- (if n
- (begin
- (set! start-index (+ start-index n))
- (if (= start-index end-index)
- (channel-close input-channel)))))))
- (channel-close input-channel))
- (copy-output)
- (let ((status (subprocess-status process)))
- (if (eq? status 'RUNNING)
- (loop)
- (begin
- (channel-blocking output-channel)
- (copy-output)
- (process-termination-message process
- status
- output-mark)))))))))))))
+ (receiver
+ (lambda ()
+ (if (< start-index end-index)
+ (let ((index (min (+ start-index 512) end-index)))
+ (let ((buffer
+ (group-extract-string group
+ start-index
+ index)))
+ (let ((n
+ (channel-write input-channel
+ buffer
+ 0
+ (string-length buffer))))
+ (if n
+ (begin
+ (set! start-index (+ start-index n))
+ (if (= start-index end-index)
+ (channel-close input-channel)))))))
+ (channel-close input-channel)))))))))
+ (begin
+ (channel-close (subprocess-output-channel process))
+ (receiver (lambda () unspecific)))))
+
+(define system-call-name
+ (condition-accessor condition-type:system-call-error 'SYSTEM-CALL))
+
+(define system-call-error
+ (condition-accessor condition-type:system-call-error 'ERROR-TYPE))
\f
;;; These procedures are not specific to the process abstraction.
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regexp.scm,v 1.49 1991/03/15 23:27:48 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regexp.scm,v 1.50 1991/04/21 00:51:43 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define match-group)
(define registers (make-vector 20))
+(define match-group)
+(define standard-syntax-table (make-syntax-table))
+
+(define-integrable (re-match-start-index i)
+ (vector-ref registers i))
+
+(define-integrable (re-match-end-index i)
+ (vector-ref registers (+ i 10)))
(define (re-match-start i)
- (let ((group (unhash match-group)))
+ (guarantee-re-register i 'RE-MATCH-START)
+ (let ((group (object-unhash match-group)))
(if (not group)
(error "No match registers" i))
(make-mark group (re-match-start-index i))))
-(define (re-match-start-index i)
- (if (or (negative? i) (> i 9))
- (error "No such register" i))
- (vector-ref registers i))
-
(define (re-match-end i)
- (let ((group (unhash match-group)))
+ (guarantee-re-register i 'RE-MATCH-END)
+ (let ((group (object-unhash match-group)))
(if (not group)
(error "No match registers" i))
(make-mark group (re-match-end-index i))))
-(define (re-match-end-index i)
- (if (or (negative? i) (> i 9))
- (error "No such register" i))
- (vector-ref registers (+ i 10)))
-
-(define (%re-finish group index)
- (if index
- (begin
- (set! match-group (hash group))
- (make-mark group index))
- (begin
- (set! match-group (hash false))
- false)))
-
-(define pattern-cache
- (make-list 32 (cons* "" "" "")))
+(define (guarantee-re-register i operator)
+ (if (not (and (exact-nonnegative-integer? i) (< i 10)))
+ (error:wrong-type-argument i "RE register" operator)))
+
+(define (replace-match replacement)
+ (let ((m (mark-left-inserting-copy (re-match-start 0))))
+ (delete-string m (re-match-end 0))
+ (insert-string m replacement)
+ (mark-temporary! m)
+ m))
+
+(define (delete-match)
+ (let ((m (mark-left-inserting-copy (re-match-start 0))))
+ (delete-string m (re-match-end 0))
+ (mark-temporary! m)
+ m))
+
+(define-integrable (syntax-table-argument syntax-table)
+ (syntax-table/entries (or syntax-table standard-syntax-table)))
+\f
+(define (re-search-buffer-forward pattern case-fold-search syntax-table
+ group start end)
+ (let ((index
+ ((ucode-primitive re-search-buffer-forward)
+ pattern
+ (re-translation-table case-fold-search)
+ (syntax-table-argument syntax-table)
+ registers
+ group start end)))
+ (set! match-group (object-hash (and index group)))
+ index))
+
+(define (re-search-buffer-backward pattern case-fold-search syntax-table
+ group start end)
+ (let ((index
+ ((ucode-primitive re-search-buffer-backward)
+ pattern
+ (re-translation-table case-fold-search)
+ (syntax-table-argument syntax-table)
+ registers
+ group start end)))
+ (set! match-group (object-hash (and index group)))
+ index))
+
+(define (re-match-buffer-forward pattern case-fold-search syntax-table
+ group start end)
+ (let ((index
+ ((ucode-primitive re-match-buffer)
+ pattern
+ (re-translation-table case-fold-search)
+ (syntax-table-argument syntax-table)
+ registers
+ group start end)))
+ (set! match-group (object-hash (and index group)))
+ index))
+
+(define (re-match-string-forward pattern case-fold-search syntax-table string)
+ (re-match-substring-forward pattern case-fold-search syntax-table
+ string 0 (string-length string)))
+
+(define (re-match-substring-forward pattern case-fold-search syntax-table
+ string start end)
+ (set! match-group (object-hash false))
+ ((ucode-primitive re-match-substring)
+ pattern
+ (re-translation-table case-fold-search)
+ (syntax-table-argument syntax-table)
+ registers
+ string start end))
-(define (compile-pattern regexp)
- ;; Incredible hair here to prevent excessive consing.
- ((if (ref-variable case-fold-search) cdr car)
- (cdr (or (assq regexp pattern-cache)
- (let ((entry
- (cons regexp
- (cons (re-compile-pattern regexp false)
- (re-compile-pattern regexp true)))))
- (set! pattern-cache
- (cons entry
- (except-last-pair! pattern-cache)))
- entry)))))
+(define (re-search-string-forward pattern case-fold-search syntax-table string)
+ (re-search-substring-forward pattern case-fold-search syntax-table
+ string 0 (string-length string)))
-(define (compile-char char)
- (re-compile-char char (ref-variable case-fold-search)))
+(define (re-search-substring-forward pattern case-fold-search syntax-table
+ string start end)
+ (set! match-group (object-hash false))
+ ((ucode-primitive re-search-substring-forward)
+ pattern
+ (re-translation-table case-fold-search)
+ (syntax-table-argument syntax-table)
+ registers
+ string start end))
-(define (compile-string string)
- (re-compile-string string (ref-variable case-fold-search)))
+(define (re-search-string-backward pattern case-fold-search syntax-table
+ string)
+ (re-search-substring-backward pattern case-fold-search syntax-table
+ string 0 (string-length string)))
+
+(define (re-search-substring-backward pattern case-fold-search syntax-table
+ string start end)
+ (set! match-group (object-hash false))
+ ((ucode-primitive re-search-substring-backward)
+ pattern
+ (re-translation-table case-fold-search)
+ (syntax-table-argument syntax-table)
+ registers
+ string start end))
\f
-;;;; Search
-
(define-macro (define-search name key-name searcher compile-key
mark-limit mark-compare)
`(DEFINE (,name ,key-name #!OPTIONAL START END LIMIT?)
(ERROR ,(string-append (symbol->string name)
": Marks incorrectly related")
START END))
- (OR (,searcher (MARK-GROUP START)
- (MARK-INDEX START)
- (MARK-INDEX END)
- (,compile-key ,key-name))
+ (OR (LET ((GROUP (MARK-GROUP START)))
+ (,searcher GROUP
+ (MARK-INDEX START)
+ (MARK-INDEX END)
+ (,compile-key ,key-name
+ (GROUP-CASE-FOLD-SEARCH GROUP))))
(LIMIT-MARK-MOTION LIMIT? END)))))))
-(define-search char-search-forward char
- %re-search-forward compile-char group-end mark<=)
-
(define-search search-forward string
- %re-search-forward compile-string group-end mark<=)
+ %re-search-forward re-compile-string group-end mark<=)
(define-search re-search-forward regexp
- %re-search-forward compile-pattern group-end mark<=)
+ %re-search-forward re-compile-pattern group-end mark<=)
(define (%re-search-forward group start end pattern)
- (%re-finish group
- ((ucode-primitive re-search-buffer-forward)
- pattern
- (re-translation-table (ref-variable case-fold-search))
- (syntax-table/entries (ref-variable syntax-table))
- registers
- group start end)))
-
-(define-search char-search-backward char
- %re-search-backward compile-char group-start mark>=)
+ (let ((index
+ (re-search-buffer-forward pattern
+ (group-case-fold-search group)
+ (group-syntax-table group)
+ group start end)))
+ (and index
+ (make-mark group index))))
(define-search search-backward string
- %re-search-backward compile-string group-start mark>=)
+ %re-search-backward re-compile-string group-start mark>=)
(define-search re-search-backward regexp
- %re-search-backward compile-pattern group-start mark>=)
+ %re-search-backward re-compile-pattern group-start mark>=)
(define (%re-search-backward group start end pattern)
- (%re-finish group
- ((ucode-primitive re-search-buffer-backward)
- pattern
- (re-translation-table (ref-variable case-fold-search))
- (syntax-table/entries (ref-variable syntax-table))
- registers
- group end start)))
-\f
-;;;; Match
-
-(define-macro (define-forward-match name key-name compile-key)
- `(DEFINE (,name ,key-name #!OPTIONAL START END)
- (LET ((START (IF (DEFAULT-OBJECT? START) (CURRENT-POINT) START)))
- (LET ((END (IF (DEFAULT-OBJECT? END) (GROUP-END START) END)))
- (IF (NOT (MARK<= START END))
- (ERROR ,(string-append (symbol->string name)
- ": Marks incorrectly related")
- START END))
- (%RE-MATCH-FORWARD (MARK-GROUP START)
- (MARK-INDEX START)
- (MARK-INDEX END)
- (,compile-key ,key-name))))))
-
-(define-forward-match char-match-forward char compile-char)
-(define-forward-match match-forward string compile-string)
-(define-forward-match re-match-forward regexp compile-pattern)
-
-(define-macro (define-backward-match name key-name key-length compile-key)
- `(DEFINE (,name ,key-name #!OPTIONAL START END)
- (LET ((START (IF (DEFAULT-OBJECT? START) (CURRENT-POINT) START)))
- (LET ((END (IF (DEFAULT-OBJECT? END) (GROUP-START START) END)))
- (IF (NOT (MARK>= START END))
- (ERROR ,(string-append (symbol->string name)
- ": Marks incorrectly related")
- START END))
- (LET ((GROUP (MARK-GROUP START))
- (START-INDEX (MARK-INDEX START))
- (END-INDEX (MARK-INDEX END)))
- (LET ((INDEX (- START-INDEX ,key-length)))
- (AND (<= END-INDEX INDEX)
- (%RE-MATCH-FORWARD GROUP
- INDEX
- START-INDEX
- (,compile-key ,key-name))
- (MAKE-MARK GROUP INDEX))))))))
-
-(define-backward-match char-match-backward
- char
- 1
- compile-char)
-
-(define-backward-match match-backward
- string
- (string-length string)
- compile-string)
-
-(define (%re-match-forward group start end pattern)
- (%re-finish group
- ((ucode-primitive re-match-buffer)
- pattern
- (re-translation-table (ref-variable case-fold-search))
- (syntax-table/entries (ref-variable syntax-table))
- registers
- group start end)))
-\f
-;;;; Quote
-
-(define re-quote-string
- (let ((special (char-set #\[ #\] #\* #\. #\\ #\? #\+ #\^ #\$)))
- (lambda (string)
- (let ((end (string-length string)))
- (let ((n
- (let loop ((start 0) (n 0))
- (let ((index
- (substring-find-next-char-in-set string start end
- special)))
- (if index
- (loop (1+ index) (1+ n))
- n)))))
- (if (zero? n)
- string
- (let ((result (string-allocate (+ end n))))
- (let loop ((start 0) (i 0))
- (let ((index
- (substring-find-next-char-in-set string start end
- special)))
- (if index
- (begin
- (substring-move-right! string start index result i)
- (let ((i (+ i (- index start))))
- (string-set! result i #\\)
- (string-set! result
- (1+ i)
- (string-ref string index))
- (loop (1+ index) (+ i 2))))
- (substring-move-right! string start end result i))))
- result)))))))
-
-;;;; Char Skip
-
-(define (skip-chars-forward pattern #!optional start end limit?)
- (let ((start (if (default-object? start) (current-point) start)))
- (let ((end (if (default-object? end) (group-end start) end)))
- (let ((limit? (if (default-object? limit?) 'LIMIT limit?)))
- (if (not (mark<= start end))
- (error "SKIP-CHARS-FORWARD: Marks incorrectly related" start end))
- (let ((index
- (%find-next-char-in-set (mark-group start)
- (mark-index start)
- (mark-index end)
- (re-compile-char-set pattern true))))
- (if index
- (make-mark (mark-group start) index)
- (limit-mark-motion limit? end)))))))
-
-(define (skip-chars-backward pattern #!optional start end limit?)
- (let ((start (if (default-object? start) (current-point) start)))
- (let ((end (if (default-object? end) (group-start start) end)))
- (let ((limit? (if (default-object? limit?) 'LIMIT limit?)))
- (if (not (mark>= start end))
- (error "SKIP-CHARS-BACKWARD: Marks incorrectly related" start end))
- (let ((index
- (%find-previous-char-in-set (mark-group start)
- (mark-index start)
- (mark-index end)
- (re-compile-char-set pattern
- true))))
- (if index
- (make-mark (mark-group start) index)
- (limit-mark-motion limit? end)))))))
-\f
-;;;; String Operations
-
-(define (re-match-string-forward pattern string)
- (re-match-substring-forward pattern string 0 (string-length string)))
-
-(define (re-match-substring-forward pattern string start end)
- ((ucode-primitive re-match-substring)
- (re-compile-pattern pattern false)
- (re-translation-table false)
- (syntax-table/entries (ref-variable syntax-table))
- registers
- string start end))
-
-(define (re-match-string-forward-ci pattern string)
- (re-match-substring-forward-ci pattern string 0 (string-length string)))
-
-(define (re-match-substring-forward-ci pattern string start end)
- ((ucode-primitive re-match-substring)
- (re-compile-pattern pattern true)
- (re-translation-table false)
- (syntax-table/entries (ref-variable syntax-table))
- registers
- string start end))
-
-(define (re-search-string-forward pattern string)
- (re-search-substring-forward pattern string 0 (string-length string)))
-
-(define (re-search-substring-forward pattern string start end)
- ((ucode-primitive re-search-substring-forward)
- (re-compile-pattern pattern false)
- (re-translation-table false)
- (syntax-table/entries (ref-variable syntax-table))
- registers
- string start end))
-
-(define (re-search-string-forward-ci pattern string)
- (re-search-substring-forward-ci pattern string 0 (string-length string)))
-
-(define (re-search-substring-forward-ci pattern string start end)
- ((ucode-primitive re-search-substring-forward)
- (re-compile-pattern pattern true)
- (re-translation-table false)
- (syntax-table/entries (ref-variable syntax-table))
- registers
- string start end))
\ No newline at end of file
+ (let ((index
+ (re-search-buffer-backward pattern
+ (group-case-fold-search group)
+ (group-syntax-table group)
+ group end start)))
+ (and index
+ (make-mark group index))))
+
+(define (re-match-forward regexp start #!optional end case-fold-search)
+ (let ((group (mark-group start)))
+ (let ((case-fold-search
+ (if (default-object? case-fold-search)
+ (group-case-fold-search group)
+ case-fold-search)))
+ (let ((index
+ (re-match-buffer-forward
+ (re-compile-pattern regexp case-fold-search)
+ case-fold-search
+ (group-syntax-table group)
+ group
+ (mark-index start)
+ (if (default-object? end)
+ (group-end-index group)
+ (begin
+ (if (not (and (eq? group (mark-group end))
+ (fix:<= (mark-index start)
+ (mark-index end))))
+ (error "Marks incorrectly related:" start end))
+ (mark-index end))))))
+ (and index
+ (make-mark group index))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/search.scm,v 1.147 1990/11/02 03:13:38 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/search.scm,v 1.148 1991/04/21 00:51:57 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; Search/Match Primitives
-;;; The operations in this file are for internal editor use only. For
-;;; the user level search and match primitives, see the regular
-;;; expression search and match procedures.
-
(declare (usual-integrations))
\f
-;;;; Character Search
-#|
-(define (find-next-char start end char)
- (if (not (mark<= start end))
- (error "Marks incorrectly related: FIND-NEXT-CHAR" start end))
- (let ((index (%find-next-char (mark-group start)
- (mark-index start)
- (mark-index end)
- char)))
- (and index (make-mark (mark-group start) index))))
-
-(define (find-previous-char start end char)
- (if (not (mark>= start end))
- (error "Marks incorrectly related: FIND-PREVIOUS-CHAR" start end))
- (let ((index (%find-previous-char (mark-group start)
- (mark-index start)
- (mark-index end)
- char)))
- (and index (make-mark (mark-group start) index))))
-|#
-(define (%find-next-newline group start end)
- ;; Assume (FIX:<= START END)
- (and (not (fix:= start end))
- (let ((start (group-index->position group start true))
- (end (group-index->position group end false)))
- (let ((position
- (if (and (fix:<= start (group-gap-start group))
- (fix:<= (group-gap-end group) end))
- (or (substring-find-next-char (group-text group)
- start
- (group-gap-start group)
- #\newline)
- (substring-find-next-char (group-text group)
- (group-gap-end group)
- end
- #\newline))
- (substring-find-next-char (group-text group)
- start
- end
- #\newline))))
- (and position
- (group-position->index group position))))))
-
-(define (%find-previous-newline group start end)
- ;; Assume (FIX:>= START END)
- (and (not (fix:= start end))
- (let ((start (group-index->position group start false))
- (end (group-index->position group end true)))
- (let ((position
- (if (and (fix:<= end (group-gap-start group))
- (fix:<= (group-gap-end group) start))
- (or (substring-find-previous-char (group-text group)
- (group-gap-end group)
- start
- #\newline)
- (substring-find-previous-char (group-text group)
- end
- (group-gap-start group)
- #\newline))
- (substring-find-previous-char (group-text group)
- end
- start
- #\newline))))
- (and position
- (fix:+ (group-position->index group position) 1))))))
-\f
-;;;; Character-set Search
-#|
-(define ((char-set-forward-search char-set) start end #!optional limit?)
- (or (find-next-char-in-set start end char-set)
- (limit-mark-motion (and (not (default-object? limit?)) limit?) end)))
-
-(define ((char-set-backward-search char-set) start end #!optional limit?)
- (or (find-previous-char-in-set start end char-set)
- (limit-mark-motion (and (not (default-object? limit?)) limit?) end)))
-
-(define (find-next-char-in-set start end char-set)
- (if (not (mark<= start end))
- (error "Marks incorrectly related: FIND-NEXT-CHAR-IN-SET" start end))
- (let ((index
- (%find-next-char-in-set (mark-group start)
- (mark-index start)
- (mark-index end)
- char-set)))
- (and index
- (make-mark (mark-group start) index))))
-
-(define (find-previous-char-in-set start end char-set)
- (if (not (mark>= start end))
- (error "Marks incorrectly related: FIND-PREVIOUS-CHAR-IN-SET" start end))
- (let ((index
- (%find-previous-char-in-set (mark-group start)
- (mark-index start)
- (mark-index end)
- char-set)))
+;;;; Character Search and Match
+
+(let-syntax
+ ((define-forward-search
+ (macro (name find-next)
+ `(DEFINE (,name GROUP START END CHAR)
+ ;; Assume (FIX:<= START END)
+ (AND (NOT (FIX:= START END))
+ (COND ((FIX:<= END (GROUP-GAP-START GROUP))
+ (,find-next (GROUP-TEXT GROUP) START END CHAR))
+ ((FIX:<= (GROUP-GAP-START GROUP) START)
+ (LET ((POSITION
+ (,find-next
+ (GROUP-TEXT GROUP)
+ (FIX:+ START (GROUP-GAP-LENGTH GROUP))
+ (FIX:+ END (GROUP-GAP-LENGTH GROUP))
+ CHAR)))
+ (AND POSITION
+ (FIX:- POSITION (GROUP-GAP-LENGTH GROUP)))))
+ ((,find-next (GROUP-TEXT GROUP)
+ START
+ (GROUP-GAP-START GROUP)
+ CHAR))
+ (ELSE
+ (LET ((POSITION
+ (,find-next (GROUP-TEXT GROUP)
+ (GROUP-GAP-END GROUP)
+ (FIX:+ END (GROUP-GAP-LENGTH GROUP))
+ CHAR)))
+ (AND POSITION
+ (FIX:- POSITION
+ (GROUP-GAP-LENGTH GROUP)))))))))))
+(define-forward-search group-find-next-char substring-find-next-char)
+(define-forward-search group-find-next-char-ci substring-find-next-char-ci)
+(define-forward-search group-find-next-char-in-set
+ substring-find-next-char-in-set))
+
+(let-syntax
+ ((define-backward-search
+ (macro (name find-previous)
+ `(DEFINE (,name GROUP START END CHAR)
+ ;; Assume (FIX:<= START END)
+ (AND (NOT (FIX:= START END))
+ (COND ((FIX:<= END (GROUP-GAP-START GROUP))
+ (,find-previous (GROUP-TEXT GROUP) START END CHAR))
+ ((FIX:<= (GROUP-GAP-START GROUP) START)
+ (LET ((POSITION
+ (,find-previous
+ (GROUP-TEXT GROUP)
+ (FIX:+ START (GROUP-GAP-LENGTH GROUP))
+ (FIX:+ END (GROUP-GAP-LENGTH GROUP))
+ CHAR)))
+ (AND POSITION
+ (FIX:- POSITION (GROUP-GAP-LENGTH GROUP)))))
+ ((,find-previous (GROUP-TEXT GROUP)
+ (GROUP-GAP-END GROUP)
+ (FIX:+ END (GROUP-GAP-LENGTH GROUP))
+ CHAR)
+ => (LAMBDA (POSITION)
+ (FIX:- POSITION (GROUP-GAP-LENGTH GROUP))))
+ (else
+ (,find-previous (GROUP-TEXT GROUP)
+ START
+ (GROUP-GAP-START GROUP)
+ CHAR))))))))
+(define-backward-search group-find-previous-char substring-find-previous-char)
+(define-backward-search group-find-previous-char-ci
+ substring-find-previous-char-ci)
+(define-backward-search group-find-previous-char-in-set
+ substring-find-previous-char-in-set))
+
+(define-integrable (%find-next-newline group start end)
+ (group-find-next-char group start end #\newline))
+
+(define-integrable (%find-previous-newline group start end)
+ ;; Note reversal of index arguments here.
+ (let ((index (group-find-previous-char group end start #\newline)))
(and index
- (make-mark (mark-group start) index))))
-|#
-(define (%find-next-char-in-set group start end char-set)
- (and (not (= start end))
- (let ((start (group-index->position group start true))
- (end (group-index->position group end false))
- (gap-start (group-gap-start group))
- (gap-end (group-gap-end group))
- (text (group-text group)))
- (let ((pos
- (if (and (<= start gap-start)
- (<= gap-end end))
- (or (substring-find-next-char-in-set text start gap-start
- char-set)
- (substring-find-next-char-in-set text gap-end end
- char-set))
- (substring-find-next-char-in-set text start end
- char-set))))
- (and pos (group-position->index group pos))))))
-
-(define (%find-previous-char-in-set group start end char-set)
- (and (not (= start end))
- (let ((start (group-index->position group start false))
- (end (group-index->position group end true))
- (gap-start (group-gap-start group))
- (gap-end (group-gap-end group))
- (text (group-text group)))
- (let ((pos
- (if (and (<= end gap-start)
- (<= gap-end start))
- (or (substring-find-previous-char-in-set text gap-end start
- char-set)
- (substring-find-previous-char-in-set text end gap-start
- char-set))
- (substring-find-previous-char-in-set text end start
- char-set))))
- (and pos (1+ (group-position->index group pos)))))))
+ (fix:+ index 1))))
\f
-;;;; String Search
-#|
-(define (find-next-string start-mark end-mark string)
- (find-next-substring start-mark end-mark string 0 (string-length string)))
-
-(define (find-next-substring start-mark end-mark string start end)
- (if (not (mark<= start-mark end-mark))
- (error "Marks incorrectly related: FIND-NEXT-SUBSTRING"
- start-mark end-mark))
- (if (= start end)
- start-mark
- (let ((index
- (%find-next-substring (mark-group start-mark)
- (mark-index start-mark)
- (mark-index end-mark)
- string start end)))
- (and index (make-mark (mark-group start-mark) index)))))
-
-(define (%find-next-string group start-index end-index string)
- (%find-next-substring group start-index end-index
- string 0 (string-length string)))
-
-(define (find-previous-string start-mark end-mark string)
- (find-previous-substring start-mark end-mark
- string 0 (string-length string)))
-
-(define (find-previous-substring start-mark end-mark string start end)
- (if (not (mark>= start-mark end-mark))
- (error "Marks incorrectly related: FIND-PREVIOUS-SUBSTRING"
- start-mark end-mark))
- (if (= start end)
- end-mark
- (let ((index
- (%find-previous-substring (mark-group start-mark)
- (mark-index start-mark)
- (mark-index end-mark)
- string start end)))
- (and index (make-mark (mark-group start-mark) index)))))
-
-(define (%find-previous-string group start-index end-index string)
- (%find-previous-substring group start-index end-index
- string 0 (string-length string)))
-
-(define (%find-next-substring group start-index end-index string start end)
- (let ((char (string-ref string start))
- (bound (- end-index (-1+ (- end start)))))
- (define (loop first)
- (and first
- (if (%match-next-substring group first end-index string start end)
- first
- (and (< first bound)
- (loop (%find-next-char group (1+ first) bound char))))))
- (and (< start-index bound)
- (loop (%find-next-char group start-index bound char)))))
-
-(define (%find-previous-substring group start-index end-index string start end)
- (let ((char (string-ref string (-1+ end)))
- (bound (+ end-index (-1+ (- end start)))))
- (define (loop first)
- (and first
- (if (%match-previous-substring group first end-index
- string start end)
- first
- (and (> first bound)
- (loop (%find-previous-char group (-1+ first) bound
- char))))))
- (and (> start-index bound)
- (loop (%find-previous-char group start-index bound char)))))
+(define (char-search-forward char start end #!optional case-fold-search)
+ (let ((group (mark-group start))
+ (start-index (mark-index start))
+ (end-index (mark-index end)))
+ (if (not (and (eq? group (mark-group end))
+ (fix:<= start-index end-index)))
+ (error "Marks incorrectly related:" start end))
+ (let ((index
+ (if (if (default-object? case-fold-search)
+ (group-case-fold-search group)
+ case-fold-search)
+ (group-find-next-char-ci group start-index end-index char)
+ (group-find-next-char group start-index end-index char))))
+ (and index
+ (make-mark group (fix:+ index 1))))))
+
+(define (char-search-backward char start end #!optional case-fold-search)
+ (let ((group (mark-group start))
+ (start-index (mark-index start))
+ (end-index (mark-index end)))
+ (if (not (and (eq? group (mark-group end))
+ (fix:>= start-index end-index)))
+ (error "Marks incorrectly related:" start end))
+ (let ((index
+ (if (if (default-object? case-fold-search)
+ (group-case-fold-search group)
+ case-fold-search)
+ (group-find-next-char-ci group end-index start-index char)
+ (group-find-next-char group end-index start-index char))))
+ (and index
+ (make-mark group index)))))
+
+(define (char-match-forward char mark #!optional case-fold-search)
+ (let ((group (mark-group mark))
+ (index (mark-index mark)))
+ (and (not (group-end-index? group index))
+ (if (if (default-object? case-fold-search)
+ (group-case-fold-search group)
+ case-fold-search)
+ (char-ci=? char (group-right-char group index))
+ (char=? char (group-right-char group index))))))
+
+(define (char-match-backward char mark #!optional case-fold-search)
+ (let ((group (mark-group mark))
+ (index (mark-index mark)))
+ (and (not (group-start-index? group index))
+ (if (if (default-object? case-fold-search)
+ (group-case-fold-search group)
+ case-fold-search)
+ (char-ci=? char (group-left-char group index))
+ (char=? char (group-left-char group index))))))
+
+(define (skip-chars-forward pattern #!optional start end limit?)
+ (let ((start (if (default-object? start) (current-point) start)))
+ (let ((end (if (default-object? end) (group-end start) end)))
+ (let ((limit? (if (default-object? limit?) 'LIMIT limit?)))
+ (if (not (mark<= start end))
+ (error "SKIP-CHARS-FORWARD: Marks incorrectly related" start end))
+ (let ((index
+ (group-find-next-char-in-set (mark-group start)
+ (mark-index start)
+ (mark-index end)
+ (re-compile-char-set pattern
+ true))))
+ (if index
+ (make-mark (mark-group start) index)
+ (limit-mark-motion limit? end)))))))
+
+(define (skip-chars-backward pattern #!optional start end limit?)
+ (let ((start (if (default-object? start) (current-point) start)))
+ (let ((end (if (default-object? end) (group-start start) end)))
+ (let ((limit? (if (default-object? limit?) 'LIMIT limit?)))
+ (if (not (mark>= start end))
+ (error "SKIP-CHARS-BACKWARD: Marks incorrectly related" start end))
+ (let ((index
+ (group-find-previous-char-in-set (mark-group start)
+ (mark-index end)
+ (mark-index start)
+ (re-compile-char-set pattern
+ true))))
+ (if index
+ (make-mark (mark-group start) (fix:+ index 1))
+ (limit-mark-motion limit? end)))))))
\f
-;;;; String Match
-
-(define (match-next-strings start end strings)
- (let loop ((strings strings))
- (and (not (null? strings))
- (or (match-next-string start end (car strings))
- (loop (cdr strings))))))
-
-(define (match-next-string start end string)
- (match-next-substring start end string 0 (string-length string)))
-
-(define (match-next-substring start-mark end-mark string start end)
- (if (not (mark<= start-mark end-mark))
- (error "marks incorrectly related" start-mark end-mark))
- (let ((index
- (%match-next-substring (mark-group start-mark)
- (mark-index start-mark)
- (mark-index end-mark)
- string start end)))
- (and index
- (make-mark (mark-group start-mark) index))))
-
-(define (match-previous-strings start end strings)
- (let loop ((strings strings))
- (and (not (null? strings))
- (or (match-previous-string start end (car strings))
- (loop (cdr strings))))))
-
-(define (match-previous-string start end string)
- (match-previous-substring start end string 0 (string-length string)))
-
-(define (match-previous-substring start-mark end-mark string start end)
- (if (not (mark>= start-mark end-mark))
- (error "marks incorrectly related" start-mark end-mark))
- (let ((index
- (%match-previous-substring (mark-group start-mark)
- (mark-index start-mark)
- (mark-index end-mark)
- string start end)))
- (and index
- (make-mark (mark-group start-mark) index))))
-
-(define (%match-next-string group start-index end-index string)
- (%match-next-substring group start-index end-index
- string 0 (string-length string)))
-
-(define (%match-previous-string group start-index end-index string)
- (%match-previous-substring group start-index end-index
- string 0 (string-length string)))
-
-(define (%match-next-substring group start-index end-index string start end)
- (let ((end-index* (+ start-index (- end start))))
- (and (<= end-index* end-index)
- (%%match-substring group start-index end-index* string start end)
- end-index*)))
-
-(define (%match-previous-substring group start-index end-index
- string start end)
- (let ((end-index* (- start-index (- end start))))
- (and (>= end-index* end-index)
- (%%match-substring group end-index* start-index string start end)
- end-index*)))
-
-(define (%%match-substring group start-index end-index string start end)
- (and (not (= start-index end-index))
- (let ((start* (group-index->position group start-index true))
- (end* (group-index->position group end-index false))
- (gap-start (group-gap-start group))
- (gap-end (group-gap-end group))
- (text (group-text group)))
- (if (and (<= start* gap-start) (<= gap-end end*))
- (let ((split (+ start (- gap-start start*))))
- (and (substring-ci=? text start* gap-start string start split)
- (substring-ci=? text gap-end end* string split end)))
- (substring-ci=? text start* end* string start end)))))
+;;;; String Search and Match
+
+(define (group-match-substring-forward group start end
+ string string-start string-end)
+ (let ((text (group-text group))
+ (gap-start (group-gap-start group))
+ (gap-length (group-gap-length group)))
+ (let ((match
+ (lambda (s1 e1 s2)
+ (let loop ((i1 s1) (i2 s2))
+ (if (or (fix:= i1 e1)
+ (fix:= i2 string-end)
+ (not (char=? (string-ref text i1)
+ (string-ref string i2))))
+ i1
+ (loop (fix:+ i1 1) (fix:+ i2 1)))))))
+ (cond ((fix:<= end gap-start)
+ (match start end string-start))
+ ((fix:<= gap-start start)
+ (fix:- (match (fix:+ start gap-length)
+ (fix:+ end gap-length)
+ string-start)
+ gap-length))
+ (else
+ (let ((index (match start gap-start string-start)))
+ (if (fix:= index gap-start)
+ (fix:- (match (fix:+ gap-start gap-length)
+ (fix:+ end gap-length)
+ (fix:+ string-start (fix:- gap-start start)))
+ gap-length)
+ index)))))))
+
+(define (group-match-substring-backward group start end
+ string string-start string-end)
+ (let ((text (group-text group))
+ (gap-start (group-gap-start group))
+ (gap-length (group-gap-length group)))
+ (let ((match
+ (lambda (s1 e1 e2)
+ (let loop ((i1 (fix:- e1 1)) (i2 (fix:- e2 1)))
+ (cond ((not (char=? (string-ref text i1)
+ (string-ref string i2)))
+ (fix:+ i1 1))
+ ((or (fix:= i1 s1) (fix:= i2 string-start))
+ i1)
+ (else
+ (loop (fix:- i1 1) (fix:- i2 1))))))))
+ (cond ((or (fix:= start end) (fix:= string-start string-end))
+ end)
+ ((fix:<= end gap-start)
+ (match start end string-end))
+ ((fix:<= gap-start start)
+ (fix:- (match (fix:+ start gap-length)
+ (fix:+ end gap-length)
+ string-end)
+ gap-length))
+ (else
+ (let ((index
+ (fix:- (match (fix:+ gap-start gap-length)
+ (fix:+ end gap-length)
+ string-end)
+ gap-length)))
+ (if (fix:= index gap-start)
+ (match start
+ gap-start
+ (fix:- string-end (fix:- end gap-start)))
+ index)))))))
\f
-;;;; Character Match
-
-(define (match-next-char start end char)
- (%match-next-char (mark-group start)
- (mark-index start)
- (mark-index end)
- char))
-
-(define (%match-next-char group start end char)
- (and (< start end)
- (char=? char (group-right-char group start))
- (1+ start)))
-
-(define (match-previous-char start end char)
- (%match-previous-char (mark-group start)
- (mark-index start)
- (mark-index end)
- char))
-
-(define (%match-previous-char group start end char)
- (and (> start end)
- (char=? char (group-left-char group start))
- (-1+ start)))
-
-(define (match-next-char-in-set start end char-set)
- (%match-next-char-in-set (mark-group start)
- (mark-index start)
- (mark-index end)
- char-set))
-
-(define (%match-next-char-in-set group start end char-set)
- (and (< start end)
- (char-set-member? char-set (group-right-char group start))
- (1+ start)))
-
-(define (match-previous-char-in-set start end char-set)
- (%match-previous-char-in-set (mark-group start)
- (mark-index start)
- (mark-index end)
- char-set))
-
-(define (%match-previous-char-in-set group start end char-set)
- (and (> start end)
- (char-set-member? char-set (group-left-char group start))
- (-1+ start)))
-|#
\ No newline at end of file
+(define (group-match-substring-forward-ci group start end
+ string string-start string-end)
+ (let ((text (group-text group))
+ (gap-start (group-gap-start group))
+ (gap-length (group-gap-length group)))
+ (let ((match
+ (lambda (s1 e1 s2)
+ (let loop ((i1 s1) (i2 s2))
+ (if (or (fix:= i1 e1)
+ (fix:= i2 string-end)
+ (not (char-ci=? (string-ref text i1)
+ (string-ref string i2))))
+ i1
+ (loop (fix:+ i1 1) (fix:+ i2 1)))))))
+ (cond ((fix:<= end gap-start)
+ (match start end string-start))
+ ((fix:<= gap-start start)
+ (fix:- (match (fix:+ start gap-length)
+ (fix:+ end gap-length)
+ string-start)
+ gap-length))
+ (else
+ (let ((index (match start gap-start string-start)))
+ (if (fix:= index gap-start)
+ (fix:- (match (fix:+ gap-start gap-length)
+ (fix:+ end gap-length)
+ (fix:+ string-start (fix:- gap-start start)))
+ gap-length)
+ index)))))))
+
+(define (group-match-substring-backward-ci group start end
+ string string-start string-end)
+ (let ((text (group-text group))
+ (gap-start (group-gap-start group))
+ (gap-length (group-gap-length group)))
+ (let ((match
+ (lambda (s1 e1 e2)
+ (let loop ((i1 (fix:- e1 1)) (i2 (fix:- e2 1)))
+ (cond ((not (char-ci=? (string-ref text i1)
+ (string-ref string i2)))
+ (fix:+ i1 1))
+ ((or (fix:= i1 s1) (fix:= i2 string-start))
+ i1)
+ (else
+ (loop (fix:- i1 1) (fix:- i2 1))))))))
+ (cond ((or (fix:= start end) (fix:= string-start string-end))
+ end)
+ ((fix:<= end gap-start)
+ (match start end string-end))
+ ((fix:<= gap-start start)
+ (fix:- (match (fix:+ start gap-length)
+ (fix:+ end gap-length)
+ string-end)
+ gap-length))
+ (else
+ (let ((index
+ (fix:- (match (fix:+ gap-start gap-length)
+ (fix:+ end gap-length)
+ string-end)
+ gap-length)))
+ (if (fix:= index gap-start)
+ (match start
+ gap-start
+ (fix:- string-end (fix:- end gap-start)))
+ index)))))))
+\f
+(define (match-forward string mark #!optional case-fold-search)
+ (let ((group (mark-group mark))
+ (start (mark-index mark))
+ (length (string-length string)))
+ (let ((end (fix:+ start length)))
+ (and (fix:<= end (group-end-index group))
+ (fix:= (if (if (default-object? case-fold-search)
+ (group-case-fold-search group)
+ case-fold-search)
+ (group-match-substring-forward-ci group start end
+ string 0 length)
+ (group-match-substring-forward group start end
+ string 0 length))
+ end)
+ (make-mark group end)))))
+
+(define (match-backward string mark #!optional case-fold-search)
+ (let ((group (mark-group mark))
+ (end (mark-index mark))
+ (length (string-length string)))
+ (let ((start (fix:- end length)))
+ (and (fix:>= start (group-start-index group))
+ (fix:= (if (if (default-object? case-fold-search)
+ (group-case-fold-search group)
+ case-fold-search)
+ (group-match-substring-backward-ci group start end
+ string 0 length)
+ (group-match-substring-backward group start end
+ string 0 length))
+ start)
+ (make-mark group start)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/sercom.scm,v 1.55 1989/08/08 10:06:29 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/sercom.scm,v 1.56 1991/04/21 00:52:01 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define (character-search forward?)
(define (char-search char)
(search-finish
- ((if forward? char-search-forward char-search-backward) char)))
+ (let ((point (current-point)))
+ (if forward?
+ (char-search-forward char point (group-end point))
+ (char-search-backward char point (group-start point))))))
(define (string-search operator)
(search-finish (operator (ref-variable search-last-string))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/shell.scm,v 1.1 1991/03/16 00:00:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/shell.scm,v 1.2 1991/04/21 00:52:05 cph Exp $
Copyright (c) 1991 Massachusetts Institute of Technology
(define (shell-directory-tracker string)
(if (ref-variable shell-dirtrack?)
- (let ((start (re-match-string-forward "^\\s *" string))
+ (let ((start
+ (re-match-string-forward (re-compile-pattern "^\\s *" false)
+ false
+ (ref-variable syntax-table)
+ string))
(end (string-length string)))
(let ((try
(let ((match
(lambda (regexp start)
- (re-match-substring-forward regexp
- string start end))))
+ (re-match-substring-forward
+ (re-compile-pattern regexp false)
+ false
+ (ref-variable syntax-table)
+ string start end))))
(lambda (command)
(let ((eoc (match command start)))
(cond ((not eoc)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/simple.scm,v 1.34 1991/04/11 03:04:45 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/simple.scm,v 1.35 1991/04/21 00:52:09 cph Exp $
;;;
;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
(if (group-end-index? group index)
(editor-error "Attempt to delete past end of buffer")
(group-delete-right-char! group index)))))
-
+\f
(define (insert-string string #!optional point)
(let ((point (if (default-object? point) (current-point) point)))
(group-insert-string! (mark-group point) (mark-index point) string)))
(let ((point (if (default-object? point) (current-point) point)))
(group-insert-substring! (mark-group point) (mark-index point)
string start end)))
+
+(define (insert-region start end #!optional point)
+ (if (not (mark<= start end))
+ (error "Marks incorrectly related:" start end))
+ (let ((point (if (default-object? point) (current-point) point)))
+ (if (mark~ start point)
+ (error "Can't copy to same group:" start))
+ (let ((group (mark-group start))
+ (start (mark-index start))
+ (end (mark-index end)))
+ (let ((text (group-text group))
+ (gap-start (group-gap-start group))
+ (gap-end (group-gap-end group))
+ (gap-length (group-gap-length group)))
+ (cond ((<= end gap-start)
+ (group-insert-substring! (mark-group point)
+ (mark-index point)
+ text
+ start
+ end))
+ ((<= gap-end start)
+ (group-insert-substring! (mark-group point)
+ (mark-index point)
+ text
+ (+ start gap-length)
+ (+ end gap-length)))
+ (else
+ (let ((point (mark-left-inserting-copy point)))
+ (group-insert-substring! (mark-group point)
+ (mark-index point)
+ text
+ start
+ gap-start)
+ (group-insert-substring! (mark-group point)
+ (mark-index point)
+ text
+ gap-end
+ (+ end gap-length))
+ (mark-temporary! point))))))))
\f
(define (extract-string mark #!optional point)
(let ((point (if (default-object? point) (current-point) point)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/struct.scm,v 1.76 1991/04/02 19:56:05 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/struct.scm,v 1.77 1991/04/21 00:52:14 cph Exp $
;;;
;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
(vector-set! group group-index:modified? sense))
(define-integrable (set-group-point! group point)
- (vector-set! group group-index:point (mark-left-inserting point)))
+ (vector-set! group group-index:point (mark-left-inserting-copy point)))
(define (with-narrowed-region! region thunk)
(with-group-text-clipped! (region-group region)
group-index:clip-daemons
(delq! daemon (vector-ref group group-index:clip-daemons))))
+(define (group-local-ref group variable)
+ (variable-local-value (let ((buffer (group-buffer group)))
+ (if (not buffer)
+ (error:bad-range-argument group
+ 'GROUP-LOCAL-REF))
+ buffer)
+ variable))
+
(define-integrable (group-tab-width group)
- (variable-local-value (group-buffer group) (ref-variable-object tab-width)))
+ (group-local-ref group (ref-variable-object tab-width)))
+
+(define-integrable (group-case-fold-search group)
+ (group-local-ref group (ref-variable-object case-fold-search)))
+
+(define-integrable (group-syntax-table group)
+ (group-local-ref group (ref-variable-object syntax-table)))
\f
;;;; Marks
mark
(group-marks group)))))
mark)
+
+(define-integrable (mark-local-ref mark variable)
+ (group-local-ref (mark-group mark) variable))
\f
(define-integrable (mark~ mark1 mark2)
(eq? (mark-group mark1) (mark-group mark2)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/things.scm,v 1.79 1991/03/22 00:33:08 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/things.scm,v 1.80 1991/04/21 00:52:20 cph Exp $
;;;
;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
(define (horizontal-space-end mark)
(skip-chars-forward " \t" mark (line-end mark 0)))
-(define (compute-horizontal-space c1 c2 receiver)
+(define (compute-horizontal-space c1 c2 tab-width)
;; Compute the number of tabs/spaces required to fill from column C1
;; to C2 with whitespace. It is assumed that C1 >= C2.
- (if (ref-variable indent-tabs-mode)
- (let ((tab-width (ref-variable tab-width)))
- (let ((qr1 (integer-divide c1 tab-width))
- (qr2 (integer-divide c2 tab-width)))
- (if (> (integer-divide-quotient qr1) (integer-divide-quotient qr2))
- (receiver (- (integer-divide-quotient qr1)
- (integer-divide-quotient qr2))
- (integer-divide-remainder qr1))
- (receiver 0
- (- (integer-divide-remainder qr1)
- (integer-divide-remainder qr2))))))
- (receiver 0 (- c2 c1))))
-
-(define (insert-horizontal-space target-column #!optional point)
- (let ((point
- (if (default-object? point)
- (current-point)
- (mark-left-inserting point))))
- (compute-horizontal-space target-column (mark-column point)
+ (if tab-width
+ (let ((qr1 (integer-divide c1 tab-width))
+ (qr2 (integer-divide c2 tab-width)))
+ (if (> (integer-divide-quotient qr1) (integer-divide-quotient qr2))
+ (values (- (integer-divide-quotient qr1)
+ (integer-divide-quotient qr2))
+ (integer-divide-remainder qr1))
+ (values 0
+ (- (integer-divide-remainder qr1)
+ (integer-divide-remainder qr2)))))
+ (values 0 (- c2 c1))))
+
+(define (insert-horizontal-space target-column #!optional point tab-width)
+ (let* ((point
+ (mark-left-inserting-copy
+ (if (default-object? point) (current-point) point)))
+ (tab-width
+ (if (default-object? tab-width)
+ (let ((buffer (mark-buffer point)))
+ (and buffer
+ (variable-local-value
+ buffer
+ (ref-variable-object indent-tabs-mode))
+ (variable-local-value
+ buffer
+ (ref-variable-object tab-width))))
+ tab-width)))
+ (with-values
+ (lambda ()
+ (compute-horizontal-space target-column
+ (mark-column point)
+ tab-width))
(lambda (n-tabs n-spaces)
- (insert-chars #\Tab n-tabs point)
- (insert-chars #\Space n-spaces point)))))
+ (insert-chars #\tab n-tabs point)
+ (insert-chars #\space n-spaces point)))
+ (mark-temporary! point)))
(define (delete-horizontal-space #!optional point)
(let ((point (if (default-object? point) (current-point) point)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/undo.scm,v 1.46 1991/04/12 23:23:41 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/undo.scm,v 1.47 1991/04/21 00:52:26 cph Exp $
;;;
;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
"p"
(lambda (argument)
(if (positive? argument)
- (let ((buffer (current-buffer)))
- (let ((undo-data (group-undo-data (buffer-group buffer))))
- (if (not undo-data)
- (editor-error "Undo information not kept for this buffer"))
- (without-interrupts
- (lambda ()
- (command-message-receive undo-command-tag
- (lambda ()
- (if (= -1 last-undone-record)
- (editor-error cant-undo-more)))
- (lambda ()
- (set! number-records-undone 0)
- (set! number-chars-left
- (string-length (undo-data-chars undo-data)))
- (set! last-undone-record (undo-data-next-record undo-data))
- (set! last-undone-char (undo-data-next-char undo-data))
- ;; This accounts for the boundary that is inserted
- ;; just before this command is called.
- (set! argument (+ argument 1))
- unspecific))
- (undo-n-records undo-data
- buffer
- (count-records-to-undo undo-data argument))))
- (set-command-message! undo-command-tag)
- (temporary-message "Undo!"))))))
+ (begin
+ (let ((buffer (current-buffer)))
+ (let ((auto-saved? (buffer-auto-saved? buffer))
+ (undo-data (group-undo-data (buffer-group buffer))))
+ (if (not undo-data)
+ (editor-error "Undo information not kept for this buffer"))
+ (without-interrupts
+ (lambda ()
+ (command-message-receive undo-command-tag
+ (lambda ()
+ (if (= -1 last-undone-record)
+ (editor-error cant-undo-more)))
+ (lambda ()
+ (set! number-records-undone 0)
+ (set! number-chars-left
+ (string-length (undo-data-chars undo-data)))
+ (set! last-undone-record
+ (undo-data-next-record undo-data))
+ (set! last-undone-char (undo-data-next-char undo-data))
+ ;; This accounts for the boundary that is inserted
+ ;; just before this command is called.
+ (set! argument (+ argument 1))
+ unspecific))
+ (undo-n-records undo-data
+ buffer
+ (count-records-to-undo undo-data
+ argument))))
+ (if (and auto-saved? (not (buffer-modified? buffer)))
+ (delete-auto-save-file! buffer))))
+ (set-command-message! undo-command-tag)
+ (temporary-message "Undo!")))))
\f
(define (count-records-to-undo undo-data argument)
(let ((records (undo-data-records undo-data)))
(let ((end (+ start (undo-record-length record))))
(if (> end (group-end-index group))
(editor-error outside-visible-range))
- (group-delete! group start end)))
+ (group-delete! group start end))
+ (set-current-point! (make-mark group start)))
((INSERT)
+ (set-current-point! (make-mark group start))
(let ((ic (- last-undone-char (undo-record-length record))))
(if (>= ic 0)
(begin
(buffer-modification-time buffer))
(buffer-not-modified! buffer)))
((BOUNDARY NOT-UNDOABLE)
- (set-current-point! (make-mark group start)))
+ unspecific)
(else
(error "Losing undo record type" (undo-record-type record))))))
(set! last-undone-record ir)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/unix.scm,v 1.14 1991/04/13 03:58:36 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/unix.scm,v 1.15 1991/04/21 00:52:35 cph Exp $
;;;
;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
;;;
(define-integrable (os/filename-as-directory filename)
(string-append filename "/"))
+(define (os/filename-directory filename)
+ (let ((end (string-length filename)))
+ (let ((index (substring-find-previous-char filename 0 end #\/)))
+ (if index
+ (substring filename 0 (+ index 1))
+ "./"))))
+
+(define (os/filename-non-directory filename)
+ (let ((end (string-length filename)))
+ (let ((index (substring-find-previous-char filename 0 end #\/)))
+ (if index
+ (substring filename (+ index 1) end)
+ filename))))
+
(define (os/completion-ignored-extensions)
(list-copy
'(".o" ".elc" "~" ".bin" ".lbin" ".fasl"
(define (os/init-file-name)
"~/.edwin")
-
+\f
(define os/find-file-initialization-filename
(let ((name-path (string->pathname ".edwin-ffi")))
(lambda (pathname)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.21 1991/02/15 18:14:14 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.22 1991/04/21 00:52:42 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(define (pathname=? x y)
(string=? (pathname->string x)
- (pathname->string y)))
\ No newline at end of file
+ (pathname->string y)))
+
+(define (string-or-false? object)
+ ;; Useful as a type for option variables.
+ (or (false? object)
+ (string? object)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rgxcmp.scm,v 1.105 1991/03/15 23:28:50 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rgxcmp.scm,v 1.106 1991/04/21 00:51:52 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(let ((j (fix:+ i 255)))
(substring-move-right! string i j result (fix:+ p 2))
(loop (fix:- n 255) j (fix:+ p 257)))))))))))
+
+(define re-quote-string
+ (let ((special (char-set #\[ #\] #\* #\. #\\ #\? #\+ #\^ #\$)))
+ (lambda (string)
+ (let ((end (string-length string)))
+ (let ((n
+ (let loop ((start 0) (n 0))
+ (let ((index
+ (substring-find-next-char-in-set string start end
+ special)))
+ (if index
+ (loop (1+ index) (1+ n))
+ n)))))
+ (if (zero? n)
+ string
+ (let ((result (string-allocate (+ end n))))
+ (let loop ((start 0) (i 0))
+ (let ((index
+ (substring-find-next-char-in-set string start end
+ special)))
+ (if index
+ (begin
+ (substring-move-right! string start index result i)
+ (let ((i (+ i (- index start))))
+ (string-set! result i #\\)
+ (string-set! result
+ (1+ i)
+ (string-ref string index))
+ (loop (1+ index) (+ i 2))))
+ (substring-move-right! string start end result i))))
+ result)))))))
\f
;;;; Char-Set Compiler
projects / mit-scheme.git / commitdiff