the editor, to reduce space and increase speed.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comint.scm,v 1.9 1991/09/19 22:12:17 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comint.scm,v 1.10 1991/10/25 00:02:54 cph Exp $
Copyright (c) 1991 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define (make-comint mode name program . switches)
+(define (make-comint mode buffer program . switches)
(let ((buffer
- (if (pair? name)
- (new-buffer (string-append "*" (car name) "*"))
- (find-or-create-buffer (string-append "*" name "*")))))
+ (if (buffer? buffer)
+ buffer
+ (find-or-create-buffer buffer))))
(if (let ((process (get-buffer-process buffer)))
(or (not process)
(not (process-runnable? process))))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.92 1991/04/21 00:30:35 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.93 1991/10/25 00:02:59 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
\f
;;;; Screens
-(define-integrable (screen-list)
+(define (screen-list)
(editor-screens current-editor))
-(define-integrable (selected-screen)
+(define (selected-screen)
(editor-selected-screen current-editor))
-(define-integrable (selected-screen? screen)
+(define (selected-screen? screen)
(eq? screen (selected-screen)))
-(define-integrable (multiple-screens?)
+(define (multiple-screens?)
(display-type/multiple-screens? (current-display-type)))
(define (make-screen buffer . make-screen-args)
(define (update-selected-screen! display-style)
(update-screen! (selected-screen) display-style))
-(define-integrable (screen0)
+(define (screen0)
(car (screen-list)))
(define (screen1+ screen)
\f
;;;; Windows
-(define-integrable (current-window)
+(define (current-window)
(screen-selected-window (selected-screen)))
(define (window-list)
(append-map screen-window-list (screen-list)))
-(define-integrable (current-window? window)
+(define (current-window? window)
(eq? window (current-window)))
-(define-integrable (window0)
+(define (window0)
(screen-window0 (selected-screen)))
(define (select-window window)
(screen-select-window! screen window)
(select-screen screen)))))))
-(define-integrable (select-cursor window)
+(define (select-cursor window)
(screen-select-cursor! (window-screen window) window))
(define (window-visible? window)
(else
window))))
\f
-(define-integrable (typein-window)
+(define (typein-window)
(screen-typein-window (selected-screen)))
-(define-integrable (typein-window? window)
+(define (typein-window? window)
(eq? window (screen-typein-window (window-screen window))))
-(define-integrable (current-message)
+(define (current-message)
(window-override-message (typein-window)))
(define (set-current-message! message)
\f
;;;; Buffers
-(define-integrable (buffer-list)
+(define (buffer-list)
(bufferset-buffer-list (current-bufferset)))
-(define-integrable (buffer-alive? buffer)
+(define (buffer-alive? buffer)
(memq buffer (buffer-list)))
-(define-integrable (buffer-names)
+(define (buffer-names)
(bufferset-names (current-bufferset)))
-(define-integrable (current-buffer? buffer)
+(define (current-buffer? buffer)
(eq? buffer (current-buffer)))
-(define-integrable (current-buffer)
+(define (current-buffer)
(window-buffer (current-window)))
-(define-integrable (previous-buffer)
+(define (previous-buffer)
(other-buffer (current-buffer)))
(define (other-buffer buffer)
(else
(car buffers)))))
-(define-integrable (bury-buffer buffer)
+(define (bury-buffer buffer)
(bufferset-bury-buffer! (current-bufferset) buffer))
-(define-integrable (find-buffer name)
+(define (find-buffer name)
(bufferset-find-buffer (current-bufferset) name))
-(define-integrable (create-buffer name)
+(define (create-buffer name)
(bufferset-create-buffer (current-bufferset) name))
-(define-integrable (find-or-create-buffer name)
+(define (find-or-create-buffer name)
(bufferset-find-or-create-buffer (current-bufferset) name))
-(define-integrable (rename-buffer buffer new-name)
+(define (rename-buffer buffer new-name)
(bufferset-rename-buffer (current-bufferset) buffer new-name))
(define (kill-buffer buffer)
(buffer-processes buffer))
(bufferset-kill-buffer! (current-bufferset) buffer))
\f
-(define-integrable (select-buffer buffer)
+(define (select-buffer buffer)
(set-window-buffer! (current-window) buffer true))
-(define-integrable (select-buffer-no-record buffer)
+(define (select-buffer-no-record buffer)
(set-window-buffer! (current-window) buffer false))
-(define-integrable (select-buffer-in-window buffer window)
+(define (select-buffer-in-window buffer window)
(set-window-buffer! window buffer true))
(define (set-window-buffer! window buffer record?)
\f
;;;; Point
-(define-integrable (current-point)
+(define (current-point)
(window-point (current-window)))
-(define-integrable (set-current-point! mark)
+(define (set-current-point! mark)
(set-window-point! (current-window) mark))
(define (set-buffer-point! buffer mark)
(set! old-point)
unspecific))))
-(define-integrable (current-column)
+(define (current-column)
(mark-column (current-point)))
\f
;;;; Mark and Region
-(define-integrable (current-mark)
+(define (current-mark)
(buffer-mark (current-buffer)))
(define (buffer-mark buffer)
(define (set-current-mark! mark)
(set-buffer-mark! (current-buffer) (guarantee-mark mark)))
-(define-integrable (set-buffer-mark! buffer mark)
+(define (set-buffer-mark! buffer mark)
(ring-set! (buffer-mark-ring buffer) 0 (mark-right-inserting-copy mark)))
(define-variable auto-push-point-notification
(not (typein-window? (current-window))))
(temporary-message notification))))
-(define-integrable (push-buffer-mark! buffer mark)
+(define (push-buffer-mark! buffer mark)
(ring-push! (buffer-mark-ring buffer) (mark-right-inserting-copy mark)))
-(define-integrable (pop-current-mark!)
+(define (pop-current-mark!)
(pop-buffer-mark! (current-buffer)))
-(define-integrable (pop-buffer-mark! buffer)
+(define (pop-buffer-mark! buffer)
(ring-pop! (buffer-mark-ring buffer)))
-(define-integrable (current-region)
+(define (current-region)
(make-region (current-point) (current-mark)))
(define (set-current-region! region)
\f
;;;; Modes and Comtabs
-(define-integrable (current-major-mode)
+(define (current-major-mode)
(buffer-major-mode (current-buffer)))
-(define-integrable (current-minor-modes)
+(define (current-minor-modes)
(buffer-minor-modes (current-buffer)))
-(define-integrable (current-comtabs)
+(define (current-comtabs)
(buffer-comtabs (current-buffer)))
-(define-integrable (set-current-major-mode! mode)
+(define (set-current-major-mode! mode)
(set-buffer-major-mode! (current-buffer) mode))
-(define-integrable (current-minor-mode? mode)
+(define (current-minor-mode? mode)
(buffer-minor-mode? (current-buffer) mode))
-(define-integrable (enable-current-minor-mode! mode)
+(define (enable-current-minor-mode! mode)
(enable-buffer-minor-mode! (current-buffer) mode))
-(define-integrable (disable-current-minor-mode! mode)
+(define (disable-current-minor-mode! mode)
(disable-buffer-minor-mode! (current-buffer) mode))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.26 1991/09/20 20:47:15 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.27 1991/10/25 00:03:03 cph Exp $
Copyright (c) 1989-91 Massachusetts Institute of Technology
(sf-edwin (sf-dependent 'edwin-syntax-table))
(sf-class (sf-dependent 'class-syntax-table)))
(for-each sf-global
- '("bufinp"
- "bufout"
- "class"
+ '("class"
"clscon"
"clsmac"
"display"
+ "key"
"macros"
"make"
"nvector"
"rename"
"rgxcmp"
"ring"
- "simple"
"strpad"
"strtab"
"termcap"
"utils"
- "winout"
"winren"
"xform"
- "key"
"xterm"))
- (for-each sf-edwin
- '("argred"
- "autold"
- "autosv"
- "basic"
- "bufcom"
- "bufmnu"
- "bufset"
- "c-mode"
- "calias"
- "cinden"
- "comint"
- "comman"
- "comtab"
- "comred"
- "debug"
- "debuge"
- "dired"
- "ed-ffi"
- "editor"
- "edtstr"
- "evlcom"
- "filcom"
- "fileio"
- "fill"
- "hlpcom"
- "info"
- "input"
- "intmod"
- "iserch"
- "keymap"
- "kilcom"
- "kmacro"
- "lincom"
- "linden"
- "loadef"
- "lspcom"
- "malias"
- "manual"
- "midas"
- "modefs"
- "modes"
- "modlin"
- "motcom"
- "pasmod"
- "print"
- "process"
- "prompt"
- "rcs"
- "reccom"
- "regcom"
- "regexp"
- "replaz"
- "rmail"
- "rmailsrt"
- "rmailsum"
- "schmod"
- "scrcom"
- "screen"
- "sendmail"
- "sercom"
- "shell"
- "struct"
- "syntax"
- "tags"
- "telnet"
- "texcom"
- "things"
- "tparse"
- "tximod"
- "undo"
- "unix"
- "wincom"
- "xcom"))
+ (sf-global "tterm" "termcap")
+ (let ((includes '("struct" "comman" "modes" "buffer" "edtstr")))
+ (let loop ((files includes) (includes '()))
+ (if (not (null? files))
+ (begin
+ (apply sf-edwin (car files) includes)
+ (loop (cdr files) (cons (car files) includes)))))
+ (for-each (lambda (filename)
+ (apply sf-edwin filename includes))
+ '("argred"
+ "autold"
+ "autosv"
+ "basic"
+ "bufcom"
+ "bufinp"
+ "bufmnu"
+ "bufout"
+ "bufset"
+ "c-mode"
+ "calias"
+ "cinden"
+ "comint"
+ "comtab"
+ "comred"
+ "curren"
+ "debug"
+ "debuge"
+ "dired"
+ "ed-ffi"
+ "editor"
+ "evlcom"
+ "filcom"
+ "fileio"
+ "fill"
+ "grpops"
+ "hlpcom"
+ "image"
+ "info"
+ "input"
+ "intmod"
+ "iserch"
+ "keymap"
+ "kilcom"
+ "kmacro"
+ "lincom"
+ "linden"
+ "loadef"
+ "lspcom"
+ "malias"
+ "manual"
+ "midas"
+ "modefs"
+ "modlin"
+ "motcom"
+ "motion"
+ "pasmod"
+ "print"
+ "process"
+ "prompt"
+ "rcs"
+ "reccom"
+ "regcom"
+ "regexp"
+ "regops"
+ "replaz"
+ "rmail"
+ "rmailsrt"
+ "rmailsum"
+ "schmod"
+ "scrcom"
+ "screen"
+ "search"
+ "sendmail"
+ "sercom"
+ "shell"
+ "simple"
+ "syntax"
+ "tags"
+ "telnet"
+ "texcom"
+ "things"
+ "tparse"
+ "tximod"
+ "undo"
+ "unix"
+ "wincom"
+ "winout"
+ "xcom")))
(for-each sf-class
'("comwin"
"modwin"
"edtfrm"))
- (sf-global "tterm" "termcap")
- (sf-global "image" "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")
(sf-class "utlwin" "window" "class")
(sf-class "bufwin" "utlwin" "window" "class" "buffer" "struct")
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regexp.scm,v 1.59 1991/08/28 02:54:31 arthur Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regexp.scm,v 1.60 1991/10/25 00:03:06 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(define (re-match-forward regexp start #!optional end case-fold-search)
(let ((group (mark-group start)))
- (let ((case-fold-search
+ (let ((end
+ (if (default-object? end)
+ (group-end-mark group)
+ (begin
+ (if (not (mark<= start end))
+ (error "Marks incorrectly related:" start end))
+ end)))
+ (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)
- (mark-index
- (if (default-object? end)
- (group-end-mark group)
- (begin
- (if (not (mark<= start end))
- (error "Marks incorrectly related:" start end))
- end))))))
+ (re-match-buffer-forward (re-compile-pattern regexp
+ case-fold-search)
+ case-fold-search
+ (group-syntax-table group)
+ group
+ (mark-index start)
+ (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/shell.scm,v 1.6 1991/10/03 10:19:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/shell.scm,v 1.7 1991/10/25 00:03:10 cph Exp $
Copyright (c) 1991 Massachusetts Institute of Technology
its value is used as a list of arguments when invoking the shell.
Otherwise, one argument `-i' is passed to the shell."
"P"
- (lambda (#!optional arg)
+ (lambda (new-buffer?)
(select-buffer
(let ((program
(or (ref-variable explicit-shell-file-name)
"/bin/sh")))
(apply make-comint
(ref-mode-object shell)
- (if (or (default-object? arg)
- (not arg))
- "shell"
- '("shell"))
+ (if (not new-buffer?) "*shell*" (new-buffer "*shell*"))
program
(let ((variable
(string-table-get editor-variables
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/simple.scm,v 1.38 1991/05/14 02:02:42 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/simple.scm,v 1.39 1991/10/25 00:03:14 cph Exp $
;;;
;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
(group-narrow! group index2 index1)))))
(define (widen #!optional point)
- (group-widen!
- (mark-group (if (default-object? point) (current-point) point))))
\ No newline at end of file
+ (let ((point (if (default-object? point) (current-point) point)))
+ (group-widen! (mark-group point))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/syntax.scm,v 1.73 1991/05/20 21:56:05 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/syntax.scm,v 1.74 1991/10/25 00:03:18 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(ERROR "Marks incorrectly related:" ,start ,end))))
(define (forward-prefix-chars start #!optional end)
- (let ((group (mark-group start)))
+ (let ((group (mark-group start))
+ (end (default-end/forward start end)))
(make-mark group
((ucode-primitive scan-forward-prefix-chars 4)
(syntax-table/entries (group-syntax-table group))
group
(mark-index start)
- (mark-index (default-end/forward start end))))))
+ (mark-index end)))))
(define (backward-prefix-chars start #!optional end)
- (let ((group (mark-group start)))
+ (let ((group (mark-group start))
+ (end (default-end/backward start end)))
(make-mark group
((ucode-primitive scan-backward-prefix-chars 4)
(syntax-table/entries (group-syntax-table group))
group
(mark-index start)
- (mark-index (default-end/backward start end))))))
+ (mark-index end)))))
(define (mark-right-char-quoted? mark)
(let ((group (mark-group mark)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/telnet.scm,v 1.3 1991/10/03 17:47:59 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/telnet.scm,v 1.4 1991/10/25 00:03:22 cph Exp $
Copyright (c) 1991 Massachusetts Institute of Technology
;;;; Run Telnet in a buffer
(declare (usual-integrations))
-\f
+
(define-variable telnet-prompt-pattern
"#f or Regexp to match prompts in telnet buffers."
#f)
(define-key 'telnet '(#\C-c #\C-q) 'telnet-send-character)
(define-key 'telnet '(#\C-c #\C-z) 'telnet-self-send)
(define-key 'telnet '(#\C-c #\C-\\) 'telnet-self-send)
-
+\f
;;;moved to "loadef.scm".
;;;(define-variable telnet-mode-hook
;;; "An event distributor that is invoked when entering Telnet mode."
(define-command telnet
"Run telnet in a buffer.
With a prefix argument, it unconditionally creates a new telnet connection.
-If port number is typed after hostname (separated by a space), use it instead
-of the default."
- "sTelnet to Host\nP"
- (lambda (host #!optional arg)
- (let ((default
- (let ((default (string-append host "-telnet")))
- (if (or (default-object? arg)
- (not arg))
- default
- (list default)))))
- (select-buffer
+If port number is typed after hostname (separated by a space),
+use it instead of the default."
+ "sTelnet to host\nP"
+ (lambda (host new-process?)
+ (select-buffer
+ (let ((mode (ref-mode-object telnet))
+ (buffer-name
+ (let ((buffer-name (string-append "*" host "-telnet*")))
+ (if (not new-process?)
+ buffer-name
+ (new-buffer buffer-name)))))
(if (re-match-string-forward
(re-compile-pattern "\\([^ ]+\\) \\([^ ]+\\)" false)
true
false
host)
- (let ((host* (substring host
- (re-match-start-index 1)
- (re-match-end-index 1))))
- (let ((port (substring host
- (re-match-start-index 2)
- (re-match-end-index 2))))
- (if (exact-nonnegative-integer? (string->number port))
- (make-comint (ref-mode-object telnet)
- default
- "telnet"
- host*
- port)
- (editor-error "Port must be a positive integer"))))
- (make-comint (ref-mode-object telnet)
- default
- "telnet"
- host))))))
+ (let ((host
+ (substring host
+ (re-match-start-index 1)
+ (re-match-end-index 1)))
+ (port
+ (substring host
+ (re-match-start-index 2)
+ (re-match-end-index 2))))
+ (if (not (exact-nonnegative-integer? (string->number port)))
+ (editor-error "Port must be a positive integer: " port))
+ (make-comint mode buffer-name "telnet" host port))
+ (make-comint mode buffer-name "telnet" host))))))
(define-command telnet-send-input
"Send input to telnet process.
Typically bound to C-c <char> where char is an interrupt key for the process
running remotely."
()
- (lambda ()
- (process-send-char (current-process)
- (last-command-key))))
+ (lambda () (process-send-char (current-process) (last-command-key))))
(define-command telnet-send-character
- "Reads a character and sends it to the telnet process."
+ "Read a character and send it to the telnet process.
+With prefix arg, the character is repeated that many times."
"p"
(lambda (argument)
(let ((char (read-quoted-char "Send Character: "))
(process (current-process)))
- (if (= argument 1)
- (process-send-char process char)
- (process-send-string process
- (make-string argument char))))))
-
+ (cond ((= argument 1)
+ (process-send-char process char))
+ ((> argument 1)
+ (process-send-string process (make-string argument char)))))))
\f
+(define (make-telnet-filter process)
+ (lambda (string start end)
+ (let ((mark (process-mark process)))
+ (and mark
+ (let ((index (mark-index mark))
+ (new-string (telnet-filter-substring string start end)))
+ (let ((new-length (string-length new-string)))
+ (group-insert-substring! (mark-group mark) index
+ new-string 0 new-length)
+ (set-mark-index! mark (+ index new-length))
+ true))))))
+
(define (telnet-filter-substring string start end)
(substring-substitute string start end
(ref-variable telnet-replacee)
"String to use as replacement in telnet output."
"")
-(define (make-telnet-filter process)
- (lambda (string start end)
- (let ((mark (process-mark process)))
- (and mark
- (let ((index (mark-index mark))
- (new-string (telnet-filter-substring string start end)))
- (let ((new-length (string-length new-string)))
- (group-insert-substring! (mark-group mark)
- index new-string 0 new-length)
- (set-mark-index! mark (+ index new-length))
- true))))))
-
(define (substring-substitute string start end source target)
(let ((length (fix:- end start))
(slength (string-length source))
(tlength (string-length target)))
- (if (fix:zero? slength)
- (error "substring-replace: Empty source" source))
(let ((alloc-length
(fix:+ length
(fix:* (fix:quotient length slength)
(char (string-ref source 0)))
(let ((result (string-allocate alloc-length)))
- (define (done copy-index write-index)
- (if (fix:< copy-index end)
- (substring-move-right! string copy-index end
- result write-index))
- (set-string-length! result
- (fix:+ write-index
- (fix:- end copy-index)))
- result)
-
(define (loop copy-index read-index write-index)
(if (fix:>= read-index end)
(done copy-index write-index)
- (let ((index (substring-find-next-char string
- read-index end
- char)))
+ (let ((index
+ (substring-find-next-char string read-index end char)))
(cond ((not index)
(done copy-index write-index))
((or (fix:= slength 1)
- (substring-prefix? source 0 slength string
- index end))
+ (substring-prefix? source 0 slength
+ string index end))
(substring-move-right! string copy-index index
result write-index)
(let ((next-write
(else
(loop copy-index (fix:+ index 1) write-index))))))
+ (define (done copy-index write-index)
+ (if (fix:< copy-index end)
+ (substring-move-right! string copy-index end
+ result write-index))
+ (set-string-length! result
+ (fix:+ write-index
+ (fix:- end copy-index)))
+ result)
+
(loop start start 0)))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff