230 lines
8.7 KiB
Scheme
230 lines
8.7 KiB
Scheme
;;;
|
||
;;; Copyright (c) 1985 Massachusetts Institute of Technology
|
||
;;;
|
||
;;; This material was developed by the Scheme project at the
|
||
;;; Massachusetts Institute of Technology, Department of
|
||
;;; Electrical Engineering and Computer Science. Permission to
|
||
;;; copy this software, to redistribute it, and to use it for any
|
||
;;; purpose is granted, subject to the following restrictions and
|
||
;;; understandings.
|
||
;;;
|
||
;;; 1. Any copy made of this software must include this copyright
|
||
;;; notice in full.
|
||
;;;
|
||
;;; 2. Users of this software agree to make their best efforts (a)
|
||
;;; to return to the MIT Scheme project any improvements or
|
||
;;; extensions that they make, so that these may be included in
|
||
;;; future releases; and (b) to inform MIT of noteworthy uses of
|
||
;;; this software.
|
||
;;;
|
||
;;; 3. All materials developed as a consequence of the use of
|
||
;;; this software shall duly acknowledge such use, in accordance
|
||
;;; with the usual standards of acknowledging credit in academic
|
||
;;; research.
|
||
;;;
|
||
;;; 4. MIT has made no warrantee or representation that the
|
||
;;; operation of this software will be error-free, and MIT is
|
||
;;; under no obligation to provide any services, by way of
|
||
;;; maintenance, update, or otherwise.
|
||
;;;
|
||
;;; 5. In conjunction with products arising from the use of this
|
||
;;; material, there shall be no use of the name of the
|
||
;;; Massachusetts Institute of Technology nor of any adaptation
|
||
;;; thereof in any advertising, promotional, or sales literature
|
||
;;; without prior written consent from MIT in each case.
|
||
;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;;
|
||
;;; Modified by Texas Instruments Inc 8/15/85
|
||
;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
|
||
;;;; Textual Entities
|
||
|
||
;;;; Motion Primitives
|
||
|
||
;;; This file "defines" various kinds of things like lines, pages,
|
||
;;; words, etc. The "definition" of a FOO entity consists of two
|
||
;;; procedures, FORWARD-FOO and BACKWARD-FOO, each of which takes
|
||
;;; three arguments: [1] a mark to start from, [2] the number of FOOs
|
||
;;; to traverse, and [3] a limit for LIMIT-MARK-MOTION. The value of
|
||
;;; the procedure should be either a mark or #!FALSE.
|
||
|
||
;;; If the number is positive, traverse that many FOOs in the given
|
||
;;; direction; if negative, in the opposite direction; and zero means
|
||
;;; don't move. It is assumed that no two FOOs overlap; they may or
|
||
;;; may not touch one another. When moving forward, stop to the right
|
||
;;; of the rightmost edge of the FOO. When moving backward, stop to
|
||
;;; the left of the leftmost edge.
|
||
|
||
;;; MAKE-MOTION-PAIR will generate these two procedures, given the
|
||
;;; simpler primitives to move forward or backward once.
|
||
|
||
(define (move-thing forward-thing argument)
|
||
(set-current-point! (forward-thing (current-point) argument 'BEEP)))
|
||
|
||
(define (make-motion-pair forward-one-thing backward-one-thing receiver)
|
||
(define (forward-thing mark n limit?)
|
||
(cond ((positive? n) (%forward-thing mark n limit?))
|
||
((negative? n) (%backward-thing mark (- n) limit?))
|
||
(else mark)))
|
||
|
||
(define (%forward-thing mark n limit?)
|
||
(define (loop mark n)
|
||
(let ((end (forward-one-thing mark (group-end mark))))
|
||
(cond ((not end) (limit-mark-motion limit? mark))
|
||
((= n 1) end)
|
||
(else (loop end (-1+ n))))))
|
||
(loop mark n))
|
||
|
||
(define (backward-thing mark n limit?)
|
||
(cond ((positive? n) (%backward-thing mark n limit?))
|
||
((negative? n) (%forward-thing mark (- n) limit?))
|
||
(else mark)))
|
||
|
||
(define (%backward-thing mark n limit?)
|
||
(define (loop mark n)
|
||
(let ((start (backward-one-thing mark (group-start mark))))
|
||
(cond ((not start) (limit-mark-motion limit? mark))
|
||
((= n 1) start)
|
||
(else (loop start (-1+ n))))))
|
||
(loop mark n))
|
||
|
||
(receiver forward-thing backward-thing))
|
||
|
||
;;;; Generic Operations
|
||
|
||
(define (move-thing-saving-point forward-thing argument)
|
||
(let ((mark (current-point)))
|
||
(push-current-mark! mark)
|
||
(set-current-point! (forward-thing mark argument 'BEEP))))
|
||
|
||
(define (mark-thing forward-thing n)
|
||
(push-current-mark! (forward-thing (current-point) n 'ERROR)))
|
||
|
||
(define (kill-thing forward-thing n)
|
||
(kill-region (forward-thing (current-point) n 'ERROR)))
|
||
|
||
;;;(define (transpose-things forward-thing n)
|
||
;;; (define (forward-once i)
|
||
;;; (let ((m4 (mark-right-inserting (forward-thing (current-point) 1 'ERROR))))
|
||
;;; (set-current-point! m4)
|
||
;;; (let ((m2 (mark-permanent! (forward-thing m4 -1 'ERROR))))
|
||
;;; (let ((m1 (mark-permanent! (forward-thing m2 -1 'ERROR))))
|
||
;;; (let ((m3 (forward-thing m1 1 'ERROR)))
|
||
;;; (region-insert! m4 (region-extract! (make-region m1 m3)))
|
||
;;; (region-insert! m1 (region-extract! (make-region m2 m4))))))))
|
||
;;;
|
||
;;; (define (backward-once i)
|
||
;;; (let ((m2 (mark-permanent! (forward-thing (current-point) -1 'ERROR))))
|
||
;;; (let ((m1 (mark-left-inserting (forward-thing m2 -1 'ERROR))))
|
||
;;; (let ((m3 (forward-thing m1 1 'ERROR))
|
||
;;; (m4 (mark-right-inserting (forward-thing m2 1 'ERROR))))
|
||
;;; (region-insert! m4 (region-extract! (make-region m1 m3)))
|
||
;;; (region-insert! m1 (region-extract! (make-region m2 m4))))
|
||
;;; (set-current-point! m1))))
|
||
;;;
|
||
;;; (define (special)
|
||
;;; (let ((m1 (normalize (current-point)))
|
||
;;; (m2 (normalize (current-mark))))
|
||
;;; (cond ((mark< m1 m2)
|
||
;;; (exchange m1 m2
|
||
;;; (lambda (m1 m2)
|
||
;;; (set-current-point! m2)
|
||
;;; (set-current-mark! m1))))
|
||
;;; ((mark< m2 m1)
|
||
;;; (exchange m2 m1
|
||
;;; (lambda (m2 m1)
|
||
;;; (set-current-point! m2)
|
||
;;; (set-current-mark! m1)))))))
|
||
;;;
|
||
;;; (define (exchange m1 m2 receiver)
|
||
;;; (let ((m1 (mark-right-inserting m1))
|
||
;;; (m3 (forward-thing m1 1 'ERROR))
|
||
;;; (m2 (mark-permanent! m2))
|
||
;;; (m4 (mark-right-inserting (forward-thing m2 1 'ERROR))))
|
||
;;; (region-insert! m4 (region-extract! (make-region m1 m3)))
|
||
;;; (region-insert! m1 (region-extract! (make-region m2 m4)))
|
||
;;; (receiver m4 m1)))
|
||
;;;
|
||
;;; (define (normalize m)
|
||
;;; (forward-thing (forward-thing m 1 'ERROR) -1 'ERROR))
|
||
;;;
|
||
;;; (cond ((positive? n) (dotimes n forward-once))
|
||
;;; ((negative? n) (dotimes (- n) backward-once))
|
||
;;; (else (special))))
|
||
|
||
;;;; Horizontal Space
|
||
|
||
(define (region-blank? region)
|
||
(not (find-next-non-blank (region-start region)
|
||
(region-end region)
|
||
#!FALSE)))
|
||
|
||
(define (line-blank? mark)
|
||
(not (find-next-non-blank (line-start mark 0 #!false)
|
||
(line-end mark 0 #!false)
|
||
#!FALSE)))
|
||
|
||
(define (horizontal-space-region mark)
|
||
(make-region (horizontal-space-start mark)
|
||
(horizontal-space-end mark)))
|
||
|
||
(define (horizontal-space-start mark)
|
||
(find-previous-non-blank mark (line-start mark 0 #!false) 'LIMIT))
|
||
|
||
(define (horizontal-space-end mark)
|
||
(find-next-non-blank mark (line-end mark 0 #!false) 'LIMIT))
|
||
|
||
;(define (compute-horizontal-space c1 c2 receiver)
|
||
;;; ;; Compute the number of tabs/spaces required to fill from column C1
|
||
;;; ;; to C2 with whitespace. It is assumed that C1 >= C2.
|
||
;;; (if indent-tabs-mode
|
||
;;; (let ((qr (integer-divide c2 tab-width)))
|
||
;;; (receiver (- (integer-divide-quotient qr) (quotient c1 tab-width))
|
||
;;; (integer-divide-remainder qr)))
|
||
;;; (receiver (- c2 c1) 0)))
|
||
;;;
|
||
;;;(define (insert-horizontal-space target-column #!optional point)
|
||
;;; (set! point
|
||
;;; (if (unassigned? point) (current-point) (mark-left-inserting point)))
|
||
;;; (compute-horizontal-space (mark-column point) target-column
|
||
;;; (lambda (n-tabs n-spaces)
|
||
;;; (insert-chars #\Tab n-tabs point)
|
||
;;; (insert-chars #\Space n-spaces point))))
|
||
|
||
(define (delete-horizontal-space)
|
||
(let ((point (current-point)))
|
||
(region-delete! (horizontal-space-region point))))
|
||
|
||
(define find-next-non-blank (char-set-forward-search char-set:non-blanks))
|
||
(define find-previous-non-blank (char-set-backward-search char-set:non-blanks))
|
||
|
||
|
||
;;;; Lines
|
||
; I could not find any calls to the following functions, so I commented
|
||
; them out. Note, they must have the #!optional fixed before they are added
|
||
; back in
|
||
|
||
;;;(define (forward-line mark n #!optional limit?)
|
||
;;; (if (unassigned? limit?) (set! limit? #!FALSE))
|
||
;;; (cond ((positive? n) (%forward-line mark n limit?))
|
||
;;; ((negative? n) (%backward-line mark (- n) limit?))
|
||
;;; (else mark)))
|
||
|
||
;;;(define %forward-line
|
||
;;; line-start)
|
||
|
||
;;;(define (backward-line mark n #!optional limit?)
|
||
;;; (if (unassigned? limit?) (set! limit? #!FALSE))
|
||
;;; (cond ((positive? n) (%backward-line mark n limit?))
|
||
;;; ((negative? n) (%forward-line mark (- n) limit?))
|
||
;;; (else mark)))
|
||
|
||
;;;(define (%backward-line mark n limit?)
|
||
;;; (line-start mark
|
||
;;; (- (if (line-start? mark)
|
||
;;; n
|
||
;;; (-1+ n)))
|
||
;;; limit?)) |