;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwfs.scm,v 1.6 1989/08/11 11:50:05 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwfs.scm,v 1.7 1989/08/14 09:21:59 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(inferior-y-end (car inferiors))
(line-end-index group start)))
(do-bottom! (cdr inferiors)
- (+ start (line-inferior-length inferiors)))))
+ (fix:+ start (line-inferior-length inferiors)))))
(let loop
((y-start (inferior-y-start (car inferiors)))
(start start)
(inferiors inferiors))
- (cond ((<= y-start 0)
+ (cond ((not (fix:positive? y-start))
(if fill-bottom? (do-bottom! inferiors start))
(set-line-inferiors! window inferiors start))
((group-start-index? group start)
(scroll-lines-up! window inferiors 0 start)
start))
(else
- (let ((end (-1+ start)))
+ (let ((end (fix:-1+ start)))
(let ((start (line-start-index group end)))
(let ((inferior (make-line-inferior window start end)))
- (let ((y-start (- y-start (inferior-y-size inferior))))
+ (let ((y-start
+ (fix:- y-start (inferior-y-size inferior))))
(set-inferior-start! inferior 0 y-start)
(loop y-start start (cons inferior inferiors))))))))))))
;; ending in Y-END and END-INDEX.
(let ((group (buffer-group buffer)))
(let loop ((y-start y-end) (end end-index))
- (if (or (>= y-start y-size)
+ (if (or (not (fix:< y-start y-size))
(group-end-index? group end))
'()
- (let ((start (1+ end)))
+ (let ((start (fix:1+ end)))
(let ((end (line-end-index group start)))
(let ((inferior (make-line-inferior window start end)))
(set-inferior-start! inferior 0 y-start)
;; that (> TAIL-START-INDEX END-INDEX), and that TAIL is non-'().
(let ((group (buffer-group buffer)))
(let loop ((y-end y-end) (end end-index))
- (let ((start (1+ end)))
- (cond ((= start tail-start-index)
+ (let ((start (fix:1+ end)))
+ (cond ((fix:= start tail-start-index)
(let ((old-y-end (inferior-y-start (car tail))))
- (cond ((> y-end old-y-end)
+ (cond ((fix:> y-end old-y-end)
(scroll-lines-down! window tail y-end))
- ((< y-end old-y-end)
+ ((fix:< y-end old-y-end)
(scroll-lines-up! window tail y-end start))
(else tail))))
- ((>= y-end y-size) '())
+ ((not (fix:< y-end y-size)) '())
(else
(let ((end (line-end-index group start)))
(let ((inferior (make-line-inferior window start end)))
(define (%set-window-start-mark! window mark force?)
(let ((start-y (%window-mark->y window mark)))
(and (or force?
- (let ((point-y (- (%window-point-y window) start-y)))
- (and (not (negative? point-y))
- (< point-y (window-y-size window)))))
+ (let ((point-y (fix:- (%window-point-y window) start-y)))
+ (and (not (fix:negative? point-y))
+ (fix:< point-y (window-y-size window)))))
(begin
(%window-scroll-y-relative! window start-y)
true))))
(define (%window-scroll-y-absolute! window y-point)
(with-instance-variables buffer-window window (y-point)
- (%window-scroll-y-relative! window (- (%window-point-y window) y-point))))
+ (%window-scroll-y-relative! window
+ (fix:- (%window-point-y window) y-point))))
(define (%window-scroll-y-relative! window y-delta)
(with-instance-variables buffer-window window (y-delta)
- (cond ((negative? y-delta)
- (let ((y-start (- (inferior-y-start (car line-inferiors)) y-delta)))
- (if (< y-start y-size)
+ (cond ((fix:negative? y-delta)
+ (let ((y-start
+ (fix:- (inferior-y-start (car line-inferiors)) y-delta)))
+ (if (fix:< y-start y-size)
(fill-top! window
(scroll-lines-down! window line-inferiors y-start)
(mark-index start-line-mark)
(redraw-at! window
(or (%window-coordinates->mark window 0 y-delta)
(buffer-start buffer))))))
- ((positive? y-delta)
+ ((fix:positive? y-delta)
(let ((inferiors (y->inferiors window y-delta)))
(if inferiors
(let ((start (inferiors->index window inferiors)))
window
(scroll-lines-up! window
inferiors
- (- (inferior-y-start (car inferiors))
- y-delta)
+ (fix:- (inferior-y-start (car inferiors))
+ y-delta)
start)
start))
(redraw-at! window
(everything-changed!
window
(lambda (window)
- (let ((y (if (positive? y-delta) 0 (-1+ (window-y-size window)))))
+ (let ((y
+ (if (fix:positive? y-delta)
+ 0
+ (fix:-1+ (window-y-size window)))))
(%set-buffer-point! buffer (%window-coordinates->mark window 0 y))
(set! point (buffer-point buffer))
(set-inferior-start! cursor-inferior 0 y)
;; Returns new list of new inferiors.
(let loop ((inferiors inferiors) (y-start y-start))
(if (or (null? inferiors)
- (>= y-start y-size))
+ (not (fix:< y-start y-size)))
'()
(begin
(set-inferior-start! (car inferiors) 0 y-start)
(line-end-index (buffer-group buffer)
start-index))
(let ((y-start (inferior-y-end (car inferiors))))
- (if (>= y-start y-size)
- '()
+ (if (fix:< y-start y-size)
(loop (cdr inferiors)
y-start
- (+ start-index
- (line-inferior-length inferiors))))))))))
\ No newline at end of file
+ (fix:+ start-index
+ (line-inferior-length inferiors)))
+ '())))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.281 1989/08/11 11:50:08 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.282 1989/08/14 09:22:03 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(mark-index (group-display-end group)))
(define-integrable (group-start-index? group index)
- (<= index (group-start-index group)))
+ (not (fix:> index (group-start-index group))))
(define-integrable (group-end-index? group index)
- (>= index (group-end-index group)))
+ (not (fix:< index (group-end-index group))))
(define (line-start-index group index)
(let ((limit (group-start-index group)))
(and py
(begin
(set-buffer-cursor-y! buffer false)
- (and (= (car py) (mark-index point))
- (< (cdr py) y-size)
+ (and (fix:= (car py) (mark-index point))
+ (fix:< (cdr py) y-size)
(cdr py)))))))
(define (%set-window-buffer! window new-buffer)
(let ((point (mark-index (buffer-point buffer)))
(start (group-start-index group))
(end (group-end-index group)))
- (cond ((< point start)
+ (cond ((fix:< point start)
(%set-buffer-point! buffer (make-mark group start)))
- ((> point end)
+ ((fix:> point end)
(%set-buffer-point! buffer (make-mark group end))))))
(set! point (buffer-point buffer))
unspecific))
(define (%window-cursor-y window)
(with-instance-variables buffer-window window ()
(let ((y (inferior-y-start cursor-inferior)))
- (and y (< y y-size) y))))
+ (and y (fix:< y y-size) y))))
\f
;;;; Override Message
(car line-inferiors)))
(define-integrable (line-inferior-length inferiors)
- (1+ (line-window-length (inferior-window (car inferiors)))))
+ (fix:1+ (line-window-length (inferior-window (car inferiors)))))
(define-integrable (blank-inferior-changed! window)
(with-instance-variables buffer-window window ()
(define-integrable (set-blank-inferior-start! window y-end)
(with-instance-variables buffer-window window (y-end)
- (if (< y-end y-size)
+ (if (fix:< y-end y-size)
(begin
- (set-inferior-size! blank-inferior x-size (- y-size y-end))
+ (set-inferior-size! blank-inferior x-size (fix:- y-size y-end))
(set-inferior-start! blank-inferior 0 y-end))
(set-inferior-start! blank-inferior false false))))
(line-end-index group start)
true))))
(loop (cdr inferiors)
- (+ start (line-inferior-length inferiors)))))
+ (fix:+ start (line-inferior-length inferiors)))))
(loop line-inferiors (mark-index start-line-mark))
(if (not override-inferior)
(set! inferiors (cons* cursor-inferior blank-inferior line-inferiors)))
(define (y->inferiors window y)
(with-instance-variables buffer-window window (y)
(define (loop previous-inferiors inferiors)
- (cond ((< y (inferior-y-start (car inferiors))) previous-inferiors)
+ (cond ((fix:< y (inferior-y-start (car inferiors))) previous-inferiors)
((null? (cdr inferiors))
- (and (< y (inferior-y-end (car inferiors)))
+ (and (fix:< y (inferior-y-end (car inferiors)))
inferiors))
(else (loop inferiors (cdr inferiors)))))
(loop false line-inferiors)))
(with-instance-variables buffer-window window (index)
;; Assumes that (>= INDEX (MARK-INDEX START-LINE-MARK)).
(define (loop inferiors start)
- (let ((new-start (+ start (line-inferior-length inferiors))))
- (if (< index new-start)
+ (let ((new-start (fix:+ start (line-inferior-length inferiors))))
+ (if (fix:< index new-start)
inferiors
(and (not (null? (cdr inferiors)))
(loop (cdr inferiors) new-start)))))
(if (eq? inferiors inferiors*)
start
(loop (cdr inferiors*)
- (+ start (line-inferior-length inferiors*)))))
+ (fix:+ start (line-inferior-length inferiors*)))))
(loop line-inferiors (mark-index start-line-mark))))
(define (y->inferiors&index window y receiver)
(with-instance-variables buffer-window window (y receiver)
;; This is used for scrolling.
(define (loop inferiors start previous-inferiors previous-start)
- (cond ((< y (inferior-y-start (car inferiors)))
+ (cond ((fix:< y (inferior-y-start (car inferiors)))
(receiver previous-inferiors previous-start))
((null? (cdr inferiors))
- (and (< y (inferior-y-end (car inferiors)))
+ (and (fix:< y (inferior-y-end (car inferiors)))
(receiver inferiors start)))
(else
- (loop (cdr inferiors) (+ start (line-inferior-length inferiors))
- inferiors start))))
+ (loop (cdr inferiors)
+ (fix:+ start (line-inferior-length inferiors))
+ inferiors
+ start))))
(loop line-inferiors (mark-index start-line-mark) false false)))
(define (start-changes-inferiors window)
(not-found (mark-index end-line-mark))
(loop (cdr inferiors)
(lambda (end)
- (let ((new-end (- end (line-inferior-length inferiors))))
- (if (< new-end index)
+ (let ((new-end (fix:- end (line-inferior-length inferiors))))
+ (if (fix:< new-end index)
inferiors
(not-found new-end)))))))
(loop line-inferiors
(recenter!
(lambda ()
(%window-redraw! window (%window-y-center window)))))
- (if (zero? threshold)
+ (if (not (object-type? (ucode-type fixnum) threshold))
+ (error "Not a small integer" threshold))
+ (if (fix:zero? threshold)
(recenter!)
- (if (< (mark-index point) (mark-index start-mark))
+ (if (fix:< (mark-index point) (mark-index start-mark))
(let ((limit
- (%window-coordinates->index window 0 (- threshold))))
- (if (or (not limit) (>= (mark-index point) limit))
+ (%window-coordinates->index window
+ 0
+ (fix:- 0 threshold))))
+ (if (or (not limit)
+ (not (fix:< (mark-index point) limit)))
(%window-scroll-y-relative! window
(%window-point-y window))
(recenter!)))
(let ((limit
(%window-coordinates->index window
0
- (+ (window-y-size window)
- threshold))))
- (if (or (not limit) (< (mark-index point) limit))
+ (fix:+ (window-y-size window)
+ threshold))))
+ (if (or (not limit) (fix:< (mark-index point) limit))
(%window-scroll-y-relative!
window
- (- (%window-point-y window) (-1+ (window-y-size window))))
+ (fix:- (%window-point-y window)
+ (fix:-1+ (window-y-size window))))
(recenter!))))))))
(define (%window-force-redraw! window redraw-type)
(set-inferior-start!
inferior
0
- (- (string-base:index->y (inferior-window inferior)
- (- start start-line))))
+ (fix:- 0
+ (string-base:index->y (inferior-window inferior)
+ (fix:- start start-line))))
(set-line-inferiors!
window
(cons inferior (fill-bottom window (inferior-y-end inferior) end))
(if (not y)
(%window-y-center window)
(begin
- (if (or (< y 0) (>= y y-size))
+ (if (or (fix:< y 0)
+ (not (fix:< y y-size)))
(error "Attempt to scroll point off window" y))
y))))
(everything-changed! window
(set-inferior-start!
inferior
0
- (- y
- (string-base:index->y (inferior-window inferior)
- (- index start))))
+ (fix:- y
+ (string-base:index->y (inferior-window inferior)
+ (fix:- index start))))
(fill-top! window (list inferior) start true))))))
(define (everything-changed! window if-not-visible)
(with-instance-variables buffer-window window (inferiors y-end)
(no-outstanding-changes! window)
(if (and (eq? inferiors line-inferiors)
- (negative? (inferior-y-start (car inferiors))))
+ (fix:negative? (inferior-y-start (car inferiors))))
(start-mark-changed! window))
(if (and (null? (cdr inferiors))
- (> y-end y-size))
+ (fix:> y-end y-size))
(end-mark-changed! window))
(update-cursor! window maybe-recenter!)))
(set! start-mark
(%make-permanent-mark
(buffer-group buffer)
- (+ (mark-index start-line-mark)
- (let ((inferior (first-line-inferior window)))
- (string-base:coordinates->index
- (inferior-window inferior)
- 0
- (- (inferior-y-start inferior)))))
+ (fix:+ (mark-index start-line-mark)
+ (let ((inferior (first-line-inferior window)))
+ (string-base:coordinates->index
+ (inferior-window inferior)
+ 0
+ (fix:- 0 (inferior-y-start inferior)))))
false))
(window-modeline-event! superior 'START-MARK-CHANGED!)))
(let ((group (buffer-group buffer)))
(%make-permanent-mark
group
- (+ (line-start-index group (mark-index end-line-mark))
- (string-base:coordinates->index
- (inferior-window last-line-inferior)
- (-1+ x-size)
- (-1+ (- (min y-size (inferior-y-end last-line-inferior))
- (inferior-y-start last-line-inferior)))))
+ (fix:+ (line-start-index group (mark-index end-line-mark))
+ (string-base:coordinates->index
+ (inferior-window last-line-inferior)
+ (fix:-1+ x-size)
+ (fix:-1+
+ (fix:- (min y-size (inferior-y-end last-line-inferior))
+ (inferior-y-start last-line-inferior)))))
true)))
(window-modeline-event! superior 'END-MARK-CHANGED!)))
(integer-divide
(* y-size (ref-variable cursor-centering-point))
100)))
- (if (< (integer-divide-remainder qr) 50)
+ (if (fix:< (integer-divide-remainder qr) 50)
(integer-divide-quotient qr)
- (1+ (integer-divide-quotient qr))))))
- (cond ((< result 0) 0)
- ((< result y-size) result)
- (else (-1+ y-size))))))
\ No newline at end of file
+ (fix:1+ (integer-divide-quotient qr))))))
+ (cond ((fix:< result 0) 0)
+ ((fix:< result y-size) result)
+ (else (fix:-1+ y-size))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwiu.scm,v 1.11 1989/08/11 11:50:13 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwiu.scm,v 1.12 1989/08/14 09:22:07 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(set! start-changes-mark
(%make-permanent-mark group start false))
(set! end-changes-mark (%make-permanent-mark group end true)))
- ((< start (mark-position start-changes-mark))
+ ((fix:< start (mark-position start-changes-mark))
(set-mark-position! start-changes-mark start))
- ((> end (mark-position end-changes-mark))
+ ((fix:> end (mark-position end-changes-mark))
(set-mark-position! end-changes-mark end)))
(if (and (not (car redisplay-flags))
- (>= end (mark-position start-line-mark))
- (<= start (mark-position end-mark)))
+ (not (fix:< end (mark-position start-line-mark)))
+ (not (fix:> start (mark-position end-mark))))
(setup-redisplay-flags! redisplay-flags))))))
;;; It is assumed that the clip daemon is called before the clipping
(end (group-index->position group end true))
(window-start (mark-position start-line-mark))
(window-end (mark-position end-mark)))
- (if (or (> start window-start)
- (< end window-end)
- (and (< start window-start)
- (= window-start (mark-position start-clip-mark)))
- (and (> end window-end)
- (= window-end (mark-position end-clip-mark))))
+ (if (or (fix:> start window-start)
+ (fix:< end window-end)
+ (and (fix:< start window-start)
+ (fix:= window-start (mark-position start-clip-mark)))
+ (and (fix:> end window-end)
+ (fix:= window-end (mark-position end-clip-mark))))
(setup-redisplay-flags! redisplay-flags)))))))
(define (update-buffer-window! window screen x-start y-start
(define (%recompute-image! window)
(with-instance-variables buffer-window window ()
- (cond ((eq? 'START force-redraw?)
- (%window-redraw-preserving-start! window))
- ((eq? 'POINT force-redraw?)
- (%window-redraw! window (%window-point-y window)))
- ((eq? 'BUFFER-CURSOR-Y force-redraw?)
- (%window-redraw! window (%window-buffer-cursor-y window)))
- ((and (integer? force-redraw?)
- (not (negative? force-redraw?))
- (< force-redraw? y-size))
- (%window-redraw! window force-redraw?))
- (force-redraw?
- (%window-redraw! window (%window-y-center window)))
- (else
+ (cond ((not force-redraw?)
(let ((group (mark-group start-mark))
(start-line (mark-index start-line-mark))
(start (mark-index start-mark))
(if start-clip-mark
(let ((new-clip-start (group-start-index group))
(new-clip-end (group-end-index group)))
- (cond ((< point-index new-clip-start)
+ (cond ((fix:< point-index new-clip-start)
(%set-buffer-point! buffer
(group-display-start group))
(set! point (buffer-point buffer)))
- ((> point-index new-clip-end)
+ ((fix:> point-index new-clip-end)
(%set-buffer-point! buffer (group-display-end group))
(set! point (buffer-point buffer))))
- (cond ((> new-clip-start start-line)
+ (cond ((fix:> new-clip-start start-line)
(%window-redraw! window false))
- ((or (< new-clip-end end)
- (and (< new-clip-start start-line)
- (= start-line (mark-index start-clip-mark)))
- (and (> new-clip-end end)
- (= end (mark-index end-clip-mark))))
+ ((or (fix:< new-clip-end end)
+ (and (fix:< new-clip-start start-line)
+ (fix:= start-line
+ (mark-index start-clip-mark)))
+ (and (fix:> new-clip-end end)
+ (fix:= end (mark-index end-clip-mark))))
(%window-redraw! window
(and (not start-changes-mark)
- (>= point-index start)
- (<= point-index end)
+ (not (fix:< point-index start))
+ (not (fix:> point-index end))
(%window-point-y window))))
(else
(destroy-mark! start-clip-mark)
(if start-changes-mark
(let ((start-changes (mark-index start-changes-mark))
(end-changes (mark-index end-changes-mark)))
- (if (and (>= end-changes start-line)
- (<= start-changes end))
- (if (<= start-changes start)
- (if (< end-changes end)
+ (if (and (not (fix:< end-changes start-line))
+ (not (fix:> start-changes end)))
+ (if (not (fix:> start-changes start))
+ (if (fix:< end-changes end)
(recompute-image!:top-changed window)
(%window-redraw! window false))
- (if (>= end-changes end)
+ (if (not (fix:< end-changes end))
(recompute-image!:bottom-changed window)
(recompute-image!:middle-changed window)))
(begin
(destroy-mark! end-changes-mark)
(set! end-changes-mark false))))))
(if point-moved?
- (update-cursor! window maybe-recenter!))))))
+ (update-cursor! window maybe-recenter!)))
+ ((eq? 'START force-redraw?)
+ (%window-redraw-preserving-start! window))
+ ((eq? 'POINT force-redraw?)
+ (%window-redraw! window (%window-point-y window)))
+ ((eq? 'BUFFER-CURSOR-Y force-redraw?)
+ (%window-redraw! window (%window-buffer-cursor-y window)))
+ ((eq? 'CENTER force-redraw?)
+ (%window-redraw! window (%window-y-center window)))
+ ((and (object-type? (ucode-type fixnum) force-redraw?)
+ (not (fix:negative? force-redraw?))
+ (fix:< force-redraw? y-size))
+ (%window-redraw! window force-redraw?))
+ (else
+ (%window-redraw! window (%window-y-center window))))))
\f
(define (recompute-image!:top-changed window)
(with-instance-variables buffer-window window ()
(end-start (line-start-index group end-index))
(end-end (line-end-index group end-index)))
(if (eq? start-inferiors end-inferiors)
- (if (= start-start end-start)
+ (if (fix:= start-start end-start)
;; In this case, the changed region was a single line before the
;; changes, and is still a single line now. All we need do is redraw
(group-extract-string group start-start start-end)
truncate-lines?)
(let ((y-end* (inferior-y-end (car start-inferiors))))
- (if (= y-end y-end*)
+ (if (fix:= y-end y-end*)
(maybe-marks-changed! window start-inferiors y-end*)
(begin
(set-cdr! start-inferiors
- (cond ((< y-end y-end*)
+ (cond ((fix:< y-end y-end*)
(scroll-lines-down! window
(cdr start-inferiors)
y-end*))
(scroll-lines-up! window
(cdr start-inferiors)
y-end*
- (1+ start-end)))
+ (fix:1+ start-end)))
(else
(fill-bottom window y-end* start-end))))
(everything-changed! window maybe-recenter!)))))
(inferior-y-end (car start-inferiors))
start-end
(cdr start-inferiors)
- (1+ end-end))))
+ (fix:1+ end-end))))
(everything-changed! window maybe-recenter!))
)
;;; continued on next page...
\f
;;; ...continued from previous page
- (if (= start-start end-start)
+ (if (fix:= start-start end-start)
;; The changed region used to be multiple lines and is now just one.
;; We must scroll the bottom of the screen up to fill in.
(scroll-lines-up! window
(cdr end-inferiors)
(inferior-y-end (car start-inferiors))
- (1+ start-end))))
+ (fix:1+ start-end))))
(everything-changed! window maybe-recenter!))
;; The most general case, we must refill the center of the screen.
truncate-lines?)
(let ((y-end (inferior-y-end (car end-inferiors)))
(tail (cdr end-inferiors)))
- (cond ((> y-end old-y-end)
+ (cond ((fix:> y-end old-y-end)
(set-cdr! end-inferiors (scroll-lines-down! window tail y-end)))
- ((< y-end old-y-end)
+ ((fix:< y-end old-y-end)
(set-cdr! end-inferiors
- (scroll-lines-up! window tail y-end (1+ end-end)))))))
+ (scroll-lines-up! window
+ tail
+ y-end
+ (fix:1+ end-end)))))))
(set-cdr! start-inferiors
(fill-middle! window
(inferior-y-end (car start-inferiors))
(with-instance-variables buffer-window window ()
(%set-buffer-point! buffer (mark1+ point))
(set! point (buffer-point buffer))
- (let ((x-start (1+ (inferior-x-start cursor-inferior)))
+ (let ((x-start (fix:1+ (inferior-x-start cursor-inferior)))
(y-start (inferior-y-start cursor-inferior)))
(screen-write-cursor! saved-screen
- (+ saved-x-start x-start)
- (+ saved-y-start y-start))
+ (fix:+ saved-x-start x-start)
+ (fix:+ saved-y-start y-start))
(screen-flush! saved-screen)
(%set-inferior-x-start! cursor-inferior x-start))))
(with-instance-variables buffer-window window ()
(%set-buffer-point! buffer (mark-1+ point))
(set! point (buffer-point buffer))
- (let ((x-start (-1+ (inferior-x-start cursor-inferior)))
+ (let ((x-start (fix:-1+ (inferior-x-start cursor-inferior)))
(y-start (inferior-y-start cursor-inferior)))
(screen-write-cursor! saved-screen
- (+ saved-x-start x-start)
- (+ saved-y-start y-start))
+ (fix:+ saved-x-start x-start)
+ (fix:+ saved-y-start y-start))
(screen-flush! saved-screen)
(%set-inferior-x-start! cursor-inferior x-start))))
\f
(with-instance-variables buffer-window window (char)
(let ((x-start (inferior-x-start cursor-inferior))
(y-start (inferior-y-start cursor-inferior)))
- (let ((x (+ saved-x-start x-start))
- (y (+ saved-y-start y-start)))
+ (let ((x (fix:+ saved-x-start x-start))
+ (y (fix:+ saved-y-start y-start)))
(screen-write-char! saved-screen x y char)
- (screen-write-cursor! saved-screen (1+ x) y)
+ (screen-write-cursor! saved-screen (fix:1+ x) y)
(screen-flush! saved-screen))
(line-window-direct-output-insert-char!
(inferior-window (car (y->inferiors window y-start)))
x-start
char)
- (%set-inferior-x-start! cursor-inferior (1+ x-start)))))
+ (%set-inferior-x-start! cursor-inferior (fix:1+ x-start)))))
(define (%direct-output-insert-newline! window)
(with-instance-variables buffer-window window ()
- (let ((y-start (1+ (inferior-y-start cursor-inferior))))
+ (let ((y-start (fix:1+ (inferior-y-start cursor-inferior))))
(let ((inferior (make-inferior window line-window)))
(%set-inferior-x-start! inferior 0)
(%set-inferior-y-start! inferior y-start)
(set! last-line-inferior inferior)
(line-window-direct-output-insert-newline!
(inferior-window inferior)))
- (let ((y-end (1+ y-start)))
- (if (< y-end y-size)
+ (let ((y-end (fix:1+ y-start)))
+ (if (fix:< y-end y-size)
(begin
- (%set-inferior-y-size! blank-inferior (- y-size y-end))
+ (%set-inferior-y-size! blank-inferior (fix:- y-size y-end))
(%set-inferior-y-start! blank-inferior y-end))
(begin
(%set-inferior-x-start! blank-inferior false)
(%set-inferior-y-start! cursor-inferior y-start)
(screen-write-cursor! saved-screen
saved-x-start
- (+ saved-y-start y-start))
+ (fix:+ saved-y-start y-start))
(screen-flush! saved-screen))))
(define (%direct-output-insert-substring! window string start end)
(with-instance-variables buffer-window window (string start end)
(let ((x-start (inferior-x-start cursor-inferior))
(y-start (inferior-y-start cursor-inferior))
- (length (- end start)))
- (let ((x (+ saved-x-start x-start))
- (y (+ saved-y-start y-start)))
+ (length (fix:- end start)))
+ (let ((x (fix:+ saved-x-start x-start))
+ (y (fix:+ saved-y-start y-start)))
(screen-write-substring! saved-screen x y string start end)
- (screen-write-cursor! saved-screen (+ x length) y)
+ (screen-write-cursor! saved-screen (fix:+ x length) y)
(screen-flush! saved-screen))
(line-window-direct-output-insert-substring!
(inferior-window (car (y->inferiors window y-start)))
x-start
string start end)
- (%set-inferior-x-start! cursor-inferior (+ x-start length)))))
\ No newline at end of file
+ (%set-inferior-x-start! cursor-inferior (fix:+ x-start length)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwmc.scm,v 1.6 1989/08/09 12:55:39 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwmc.scm,v 1.7 1989/08/14 09:22:12 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(let ((start (line-start-index group end)))
(let ((columns (group-column-length group start end 0)))
(let ((y-start
- (- y-end (column->y-size columns x-size truncate-lines?))))
- (if (<= start index)
- (done start columns y-start)
- (search-upwards (-1+ start) y-start))))))
+ (fix:- y-end
+ (column->y-size columns x-size truncate-lines?))))
+ (if (fix:> start index)
+ (search-upwards (fix:-1+ start) y-start)
+ (done start columns y-start))))))
(define (search-downwards start y-start)
(let ((end (line-end-index group start)))
(let ((columns (group-column-length group start end 0)))
- (if (<= index end)
- (done start columns y-start)
- (search-downwards (1+ end)
- (+ y-start
- (column->y-size columns
- x-size
- truncate-lines?)))))))
+ (if (fix:> index end)
+ (search-downwards (fix:1+ end)
+ (fix:+ y-start
+ (column->y-size columns
+ x-size
+ truncate-lines?)))
+ (done start columns y-start)))))
(define-integrable (done start columns y-start)
(let ((xy
start
index
0))))
- (cons (car xy) (+ (cdr xy) y-start))))
+ (cons (car xy) (fix:+ (cdr xy) y-start))))
(let ((start (mark-index start-line-mark))
(end (mark-index end-line-mark)))
- (cond ((< index start)
- (search-upwards (-1+ start)
+ (cond ((fix:< index start)
+ (search-upwards (fix:-1+ start)
(inferior-y-start
(first-line-inferior window))))
- ((> index end)
- (search-downwards (1+ end)
+ ((fix:> index end)
+ (search-downwards (fix:1+ end)
(inferior-y-end last-line-inferior)))
(else
(let ((start (line-start-index group index)))
(let ((group (buffer-group buffer)))
(define (search-upwards start y-end)
(and (not (group-start-index? group start))
- (let ((end (-1+ start)))
+ (let ((end (fix:-1+ start)))
(let ((start (line-start-index group end)))
- (let ((y-start (- y-end (y-delta start end))))
- (if (<= y-start y)
- (done start end y-start)
- (search-upwards start y-start)))))))
+ (let ((y-start (fix:- y-end (y-delta start end))))
+ (if (fix:> y-start y)
+ (search-upwards start y-start)
+ (done start end y-start)))))))
(define (search-downwards end y-start)
(and (not (group-end-index? group end))
- (let ((start (1+ end)))
+ (let ((start (fix:1+ end)))
(let ((end (line-end-index group start)))
- (let ((y-end (+ y-start (y-delta start end))))
- (if (< y y-end)
+ (let ((y-end (fix:+ y-start (y-delta start end))))
+ (if (fix:< y y-end)
(done start end y-start)
(search-downwards end y-end)))))))
(define (done start end y-start)
(let ((column-size (group-column-length group start end 0)))
- (if (and truncate-lines? (= x (-1+ x-size)))
+ (if (and truncate-lines? (fix:= x (fix:-1+ x-size)))
column-size
(group-column->index group start end 0
(min (coordinates->column x
- (- y y-start)
+ (fix:- y y-start)
x-size)
column-size)))))
(let ((start (inferior-y-start (first-line-inferior window)))
(end (inferior-y-end last-line-inferior)))
- (cond ((< y start)
+ (cond ((fix:< y start)
(search-upwards (mark-index start-line-mark) start))
- ((>= y end) (search-downwards (mark-index end-line-mark) end))
+ ((not (fix:< y end))
+ (search-downwards (mark-index end-line-mark) end))
(else
(y->inferiors&index window y
(lambda (inferiors index)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/calias.scm,v 1.7 1989/08/08 10:05:40 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/calias.scm,v 1.8 1989/08/14 09:22:15 cph Rel $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define-integrable (ascii-controlified? char)
(< (char-code char) #x20))
+\f
+(define-variable enable-emacs-key-names
+ "*If true, keys are shown using Emacs-style names."
+ true)
+
+(define (char-name char)
+ (if (ref-variable enable-emacs-key-names)
+ (emacs-char-name char true)
+ (char->name (unmap-alias-char char))))
+
+(define (emacs-char-name char handle-prefixes?)
+ (let ((code (char-code char))
+ (bits (char-bits char))
+ (normal (lambda () (char->name (unmap-alias-char char)))))
+ (let ((process-code
+ (lambda ()
+ (cond ((< #x20 code #x7F) (char->name (make-char code 0)))
+ ((= code #x09) "TAB")
+ ((= code #x0A) "LFD")
+ ((= code #x0D) "RET")
+ ((= code #x1B) "ESC")
+ ((= code #x20) "SPC")
+ ((= code #x7F) "DEL")
+ (else
+ (char->name
+ (make-char (+ code (if (<= #x01 code #x1A) #x60 #x40))
+ 2)))))))
+ (cond ((zero? bits) (process-code))
+ ((not handle-prefixes?) (normal))
+ ((= 1 bits) (string-append "ESC " (process-code)))
+ ((= 2 bits) (string-append "C-^ " (process-code)))
+ ((= 3 bits) (string-append "C-z " (process-code)))
+ (else (normal))))))
+
+(define (xchar->name xchar)
+ (let ((chars (xchar->list xchar)))
+ (string-append-separated
+ (char-name (car chars))
+ (let ((char-name
+ (if (ref-variable enable-emacs-key-names)
+ (lambda (char)
+ (emacs-char-name char false))
+ (lambda (char)
+ (char->name (unmap-alias-char char))))))
+ (let loop ((chars (cdr chars)))
+ (if (null? chars)
+ ""
+ (string-append-separated
+ (char-name (car chars))
+ (loop (cdr chars)))))))))
+
+(define (xchar<? x y)
+ (let loop ((x (xchar->list x)) (y (xchar->list y)))
+ (or (char<? (car x) (car y))
+ (and (char=? (car x) (car y))
+ (not (null? (cdr y)))
+ (or (null? (cdr x))
+ (loop (cdr x) (cdr y)))))))
-(define-integrable (char-name char)
- (char->name (unmap-alias-char char)))
\ No newline at end of file
+(define (xchar->list xchar)
+ (cond ((char? xchar)
+ (list xchar))
+ ((and (not (null? xchar))
+ (list-of-type? xchar char?))
+ xchar)
+ ((and (string? xchar)
+ (not (string-null? xchar)))
+ (string->list xchar))
+ (else
+ (error "Not a character or list of characters" xchar))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comtab.scm,v 1.56 1989/08/11 11:50:20 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comtab.scm,v 1.57 1989/08/14 09:22:19 cph Rel $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;; Filter out shadowed bindings.
(list-transform-positive (search-comtabs comtabs)
(lambda (xchar)
- (eq? command (comtab-entry comtabs xchar)))))
\ No newline at end of file
+ (eq? command (comtab-entry comtabs xchar)))))
+
+(define (comtab->alist comtab)
+ (let loop ((prefix '()) (da (comtab-dispatch-alists comtab)))
+ (append! (map (lambda (element)
+ (cons (append prefix (list (car element)))
+ (cdr element)))
+ (cdr da))
+ (append-map (lambda (element)
+ (loop (append prefix (list (car element)))
+ (cdr element)))
+ (car da)))))
\ No newline at end of file
-(fluid-let ((sf/default-syntax-table syntax-table/system-internal))
- (sf-conditionally
- '("bufinp"
- "bufott"
- "bufout"
- "class"
- "clscon"
- "clsmac"
- "comtab"
- "cterm"
- "display"
- "entity"
- "grpops"
- "image"
- "macros"
- "make"
- "motion"
- "nvector"
- "paths"
- "regops"
- "rename"
- "rgxcmp"
- "ring"
- "screen"
- "search"
- "simple"
- "strpad"
- "strtab"
- "utils"
- "winout"
- "winren"
- "xform"
- "xterm")))
+#| -*-Scheme-*-
-(fluid-let ((sf/default-syntax-table
- (access edwin-syntax-table (->environment '(EDWIN)))))
- (sf-conditionally
- '("argred"
- "autold"
- "autosv"
- "basic"
- "bufcom"
- "buffer"
- "bufmnu"
- "bufset"
- "c-mode"
- "calias"
- "cinden"
- "comman"
- "comred"
- "curren"
- "debug"
- "debuge"
- "dired"
- "ed-ffi"
- "editor"
- "edtstr"
- "evlcom"
- "filcom"
- "fileio"
- "fill"
- "hlpcom"
- "info"
- "input"
- "intmod"
- "iserch"
- "keymap"
- "kilcom"
- "kmacro"
- "lincom"
- "linden"
- "loadef"
- "lspcom"
- "midas"
- "modefs"
- "modes"
- "modlin"
- "motcom"
- "pasmod"
- "prompt"
- "reccom"
- "regcom"
- "regexp"
- "replaz"
- "schmod"
- "sercom"
- "struct"
- "syntax"
- "tags"
- "texcom"
- "things"
- "tparse"
- "tximod"
- "undo"
- "unix"
- "wincom"
- "xcom")))
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.9 1989/08/14 09:22:22 cph Exp $
-(fluid-let ((sf/default-syntax-table
- (access class-syntax-table (->environment '(EDWIN)))))
- (sf-conditionally
- '("window"
- "utlwin"
- "linwin"
- "bufwin"
- "bufwfs"
- "bufwiu"
- "bufwmc"
- "comwin"
- "modwin"
- "buffrm"
- "edtfrm"
- "winmis"
- "rescrn")))
\ No newline at end of file
+Copyright (c) 1989 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. |#
+
+;;;; Edwin: Syntaxing Declarations
+
+(declare (usual-integrations))
+\f
+(let* ((scm-file (lambda (file) (string-append file ".scm")))
+ (bin-file (lambda (file) (string-append file ".bin")))
+ (bin-time (lambda (file) (file-modification-time (bin-file file))))
+ (sf-dependent
+ (lambda (syntax-table)
+ (lambda (source . dependencies)
+ (let ((reasons
+ (let ((source-time (bin-time source)))
+ (append
+ (if (not (file-processed? source "scm" "bin"))
+ (list (scm-file source))
+ '())
+ (map bin-file
+ (list-transform-positive dependencies
+ (lambda (dependency)
+ (< source-time (bin-time dependency)))))))))
+ (if (not (null? reasons))
+ (begin
+ (newline)
+ (write-string "Processing ")
+ (write source)
+ (write-string " because of:")
+ (for-each (lambda (reason)
+ (write-char #\space)
+ (write reason))
+ reasons)
+ (fluid-let ((sf/default-syntax-table
+ (lexical-reference (->environment '(EDWIN))
+ syntax-table))
+ (sf/default-declarations
+ (map (lambda (dependency)
+ `(integrate-external ,dependency))
+ dependencies)))
+ (sf source))))))))
+ (sf-global (sf-dependent 'syntax-table/system-internal))
+ (sf-edwin (sf-dependent 'edwin-syntax-table))
+ (sf-class (sf-dependent 'class-syntax-table)))
+ (for-each sf-global
+ '("bufinp"
+ "bufott"
+ "bufout"
+ "class"
+ "clscon"
+ "clsmac"
+ "comtab"
+ "cterm"
+ "display"
+ "entity"
+ "image"
+ "macros"
+ "make"
+ "nvector"
+ "paths"
+ "rename"
+ "rgxcmp"
+ "ring"
+ "screen"
+ "search"
+ "simple"
+ "strpad"
+ "strtab"
+ "utils"
+ "winout"
+ "winren"
+ "xform"
+ "xterm"))
+ (for-each sf-edwin
+ '("argred"
+ "autold"
+ "autosv"
+ "basic"
+ "bufcom"
+ "buffer"
+ "bufmnu"
+ "bufset"
+ "c-mode"
+ "calias"
+ "cinden"
+ "comman"
+ "comred"
+ "curren"
+ "debug"
+ "debuge"
+ "dired"
+ "ed-ffi"
+ "editor"
+ "edtstr"
+ "evlcom"
+ "filcom"
+ "fileio"
+ "fill"
+ "hlpcom"
+ "info"
+ "input"
+ "intmod"
+ "iserch"
+ "keymap"
+ "kilcom"
+ "kmacro"
+ "lincom"
+ "linden"
+ "loadef"
+ "lspcom"
+ "midas"
+ "modefs"
+ "modes"
+ "modlin"
+ "motcom"
+ "pasmod"
+ "prompt"
+ "reccom"
+ "regcom"
+ "regexp"
+ "replaz"
+ "schmod"
+ "sercom"
+ "struct"
+ "syntax"
+ "tags"
+ "texcom"
+ "things"
+ "tparse"
+ "tximod"
+ "undo"
+ "unix"
+ "wincom"
+ "xcom"))
+ (for-each sf-class
+ '("comwin"
+ "modwin"
+ "buffrm"
+ "edtfrm"
+ "winmis"
+ "rescrn"))
+ (sf-edwin "grpops" "struct")
+ (sf-edwin "regops" "struct")
+ (sf-edwin "motion" "struct")
+ (sf-class "window" "class")
+ (sf-class "utlwin" "window" "class")
+ (sf-class "linwin" "window" "class")
+ (sf-class "bufwin" "window" "class" "struct")
+ (sf-class "bufwfs" "bufwin" "window" "class" "struct")
+ (sf-class "bufwiu" "bufwin" "window" "class" "struct")
+ (sf-class "bufwmc" "bufwin" "window" "class" "struct"))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.11 1989/08/12 08:32:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.12 1989/08/14 09:22:26 cph Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
(files "comtab")
(parent (edwin))
(export (edwin)
+ comtab->alist
comtab-entry
comtab-dispatch-alists
comtab-key-bindings
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/grpops.scm,v 1.6 1989/04/28 22:50:01 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/grpops.scm,v 1.7 1989/08/14 09:22:30 cph Rel $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(let ((text (group-text group))
(gap-start (group-gap-start group))
(length (group-gap-length group)))
- (cond ((<= end gap-start)
+ (cond ((not (fix:> end gap-start))
(substring text start end))
- ((>= start gap-start)
- (substring text (+ start length) (+ end length)))
+ ((not (fix:< start gap-start))
+ (substring text (fix:+ start length) (fix:+ end length)))
(else
- (let ((string (string-allocate (- end start))))
+ (let ((string (string-allocate (fix:- end start))))
(substring-move-right! text start gap-start string 0)
- (substring-move-right! text (group-gap-end group) (+ end length)
- string (- gap-start start))
+ (substring-move-right! text
+ (group-gap-end group)
+ (fix:+ end length)
+ string
+ (fix:- gap-start start))
string)))))
(define (group-left-char group index)
(string-ref (group-text group)
- (-1+ (group-index->position group index false))))
+ (fix:-1+ (group-index->position group index false))))
(define (group-right-char group index)
- (string-ref (group-text group)
- (group-index->position group index true)))
+ (string-ref (group-text group) (group-index->position group index true)))
(define (group-insert-char! group index char)
(without-interrupts
(move-gap-to! group index)
(guarantee-gap-length! group 1)
(string-set! (group-text group) index char)
- (vector-set! group group-index:gap-length (-1+ (group-gap-length group)))
- (let ((gap-start* (1+ index)))
+ (vector-set! group group-index:gap-length (fix:-1+ (group-gap-length group)))
+ (let ((gap-start* (fix:1+ index)))
(vector-set! group group-index:gap-start gap-start*)
(undo-record-insertion! group index gap-start*)))
(define-integrable (%group-insert-substring! group index string start end)
(if (group-read-only? group) (barf-if-read-only))
(move-gap-to! group index)
- (let ((n (- end start)))
+ (let ((n (fix:- end start)))
(guarantee-gap-length! group n)
(substring-move-right! string start end (group-text group) index)
- (vector-set! group group-index:gap-length (- (group-gap-length group) n))
- (let ((gap-start* (+ index n)))
+ (vector-set! group
+ group-index:gap-length
+ (fix:- (group-gap-length group) n))
+ (let ((gap-start* (fix:+ index n)))
(vector-set! group group-index:gap-start gap-start*)
(undo-record-insertion! group index gap-start*))))
\f
(define (group-delete-left-char! group index)
- (group-delete! group (-1+ index) index))
+ (group-delete! group (fix:-1+ index) index))
(define (group-delete-right-char! group index)
- (group-delete! group index (1+ index)))
+ (group-delete! group index (fix:1+ index)))
(define (group-delete! group start end)
(without-interrupts
(lambda ()
- (if (not (= start end))
+ (if (not (fix:= start end))
(begin
(if (group-read-only? group) (barf-if-read-only))
;; Guarantee that the gap is between START and END.
(let ((gap-start (group-gap-start group)))
- (cond ((< gap-start start) (move-gap-to-right! group start))
- ((> gap-start end) (move-gap-to-left! group end))))
+ (cond ((fix:< gap-start start) (move-gap-to-right! group start))
+ ((fix:> gap-start end) (move-gap-to-left! group end))))
(undo-record-deletion! group start end)
(record-deletion! group start end)
- (let* ((end (+ end (group-gap-length group)))
- (length (- end start))
+ (let* ((end (fix:+ end (group-gap-length group)))
+ (length (fix:- end start))
(max-length gap-maximum-extra))
- (if (> length max-length)
- (let* ((new-end (+ start max-length))
- (difference (- length max-length))
+ (if (fix:> length max-length)
+ (let* ((new-end (fix:+ start max-length))
+ (difference (fix:- length max-length))
(text (group-text group))
(end* (string-length text))
- (new-end* (- end* difference)))
+ (new-end* (fix:- end* difference)))
(substring-move-left! text end end* text new-end)
(set-string-maximum-length! text new-end*)
(for-each-mark group
(lambda (mark)
(let ((position (mark-position mark)))
- (cond ((> position end)
- (set-mark-position! mark
- (- position difference)))
- ((<= start position)
+ (cond ((fix:> position end)
+ (set-mark-position!
+ mark
+ (fix:- position difference)))
+ ((not (fix:> start position))
(set-mark-position!
mark
(if (mark-left-inserting? mark)
(for-each-mark group
(lambda (mark)
(let ((position (mark-position mark)))
- (if (and (<= start position)
- (<= position end))
+ (if (and (not (fix:> start position))
+ (not (fix:> position end)))
(set-mark-position!
mark
(if (mark-left-inserting? mark) end start))))))
(define (move-gap-to! group index)
(let ((gap-start (group-gap-start group)))
- (cond ((< index gap-start) (move-gap-to-left! group index))
- ((> index gap-start) (move-gap-to-right! group index)))))
+ (cond ((fix:< index gap-start) (move-gap-to-left! group index))
+ ((fix:> index gap-start) (move-gap-to-right! group index)))))
(define (move-gap-to-left! group new-start)
(let ((start (group-gap-start group))
(length (group-gap-length group))
(text (group-text group)))
- (let ((new-end (+ new-start length)))
+ (let ((new-end (fix:+ new-start length)))
(for-each-mark group
(lambda (mark)
(let ((position (mark-position mark)))
- (cond ((and (< new-start position) (<= position start))
- (set-mark-position! mark (+ position length)))
- ((and (mark-left-inserting? mark) (= new-start position))
+ (cond ((and (fix:< new-start position)
+ (not (fix:> position start)))
+ (set-mark-position! mark (fix:+ position length)))
+ ((and (mark-left-inserting? mark)
+ (fix:= new-start position))
(set-mark-position! mark new-end))))))
(substring-move-right! text new-start start text new-end)
(vector-set! group group-index:gap-start new-start)
- (vector-set! group group-index:gap-end new-end)))
- unspecific)
+ (vector-set! group group-index:gap-end new-end)
+ unspecific)))
(define (move-gap-to-right! group new-start)
(let ((start (group-gap-start group))
(end (group-gap-end group))
(length (group-gap-length group))
(text (group-text group)))
- (let ((new-end (+ new-start length)))
+ (let ((new-end (fix:+ new-start length)))
(for-each-mark group
(lambda (mark)
(let ((position (mark-position mark)))
- (cond ((and (> new-end position) (>= position end))
- (set-mark-position! mark (- position length)))
- ((and (not (mark-left-inserting? mark)) (= new-end position))
+ (cond ((and (fix:> new-end position)
+ (not (fix:< position end)))
+ (set-mark-position! mark (fix:- position length)))
+ ((and (not (mark-left-inserting? mark))
+ (fix:= new-end position))
(set-mark-position! mark new-start))))))
(substring-move-left! text end new-end text start)
(vector-set! group group-index:gap-start new-start)
- (vector-set! group group-index:gap-end new-end)))
- unspecific)
+ (vector-set! group group-index:gap-end new-end)
+ unspecific)))
(define (guarantee-gap-length! group n)
- (if (< (group-gap-length group) n)
- (let ((n (+ n gap-allocation-extra))
+ (if (fix:< (group-gap-length group) n)
+ (let ((n (fix:+ n gap-allocation-extra))
(text (group-text group))
(start (group-gap-start group))
(end (group-gap-end group))
(length (group-gap-length group)))
(let ((end* (string-length text)))
- (let ((text* (string-allocate (+ end* n)))
- (new-end (+ end n)))
+ (let ((text* (string-allocate (fix:+ end* n)))
+ (new-end (fix:+ end n)))
(substring-move-right! text 0 start text* 0)
(substring-move-right! text end end* text* new-end)
(vector-set! group group-index:text text*)
(vector-set! group group-index:gap-end new-end)
- (if (zero? length)
- (for-each-mark group
+ (for-each-mark group
+ (if (fix:zero? length)
(lambda (mark)
(let ((position (mark-position mark)))
- (cond ((> position end)
- (set-mark-position! mark (+ position n)))
- ((= position end)
- (set-mark-position!
- mark
- (if (mark-left-inserting? mark)
- new-end
- start)))))))
- (for-each-mark group
+ (if (not (fix:< position end))
+ (set-mark-position!
+ mark
+ (cond ((fix:> position end) (fix:+ position n))
+ ((mark-left-inserting? mark) new-end)
+ (else start))))))
(lambda (mark)
(let ((position (mark-position mark)))
- (if (>= position end)
- (set-mark-position! mark (+ position n)))))))))
- (vector-set! group group-index:gap-length (+ length n))))
- unspecific)
\ No newline at end of file
+ (if (not (fix:< position end))
+ (set-mark-position! mark (fix:+ position n)))))))))
+ (vector-set! group group-index:gap-length (fix:+ length n))
+ unspecific)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.90 1989/08/12 08:32:15 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.91 1989/08/14 09:22:33 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define-command help-prefix
"This is a prefix for more commands.
It reads another character (a subcommand) and dispatches on it."
- "cA C F I K L M T V W or C-h for more help"
+ "cA B C F I K L M T V W or C-h for more help"
(lambda (char)
(dispatch-on-char
(current-comtabs)
(insert-string
"You have typed C-h, the help character. Type a Help option:
-A command-apropos. Type a substring, and see a list of commands
- that contain that substring.
-C describe-key-briefly. Type a key sequence;
- it prints the name of the command that sequence runs.
-F describe-command. Type a command name and get its documentation.
-I info. The Info documentation reader.
-K describe-key. Type a key sequence;
- it prints the full documentation.
-L view-lossage. Prints the last 100 characters you typed.
-M describe-mode. Print documentation of current major mode,
- which describes the commands peculiar to it.
-T help-with-tutorial. Select the Emacs learn-by-doing tutorial.
-V describe-variable. Type a variable name and get its documentation.
-W where-is. Type a command name and get its key binding."
+A command-apropos. Type a substring, and see a list of commands
+ that contain that substring.
+B describe-bindings. Display table of all key bindings.
+C describe-key-briefly. Type a key sequence;
+ it prints the name of the command that sequence runs.
+F describe-command. Type a command name and get its documentation.
+I info. The Info documentation reader.
+K describe-key. Type a key sequence;
+ it prints the full documentation.
+L view-lossage. Prints the last 100 characters you typed.
+M describe-mode. Print documentation of current major mode,
+ which describes the commands peculiar to it.
+T help-with-tutorial. Select the Emacs learn-by-doing tutorial.
+V describe-variable. Type a variable name and get its documentation.
+W where-is. Type a command name and get its key binding."
(buffer-point buffer))
(set-buffer-point! buffer (buffer-start buffer))
(buffer-not-modified! buffer)
(let loop ()
(let ((char
(prompt-for-char
- "A C F I K L M T V W or space to scroll"))) (let ((test-for
+ "A B C F I K L M T V W or space to scroll")))
+ (let ((test-for
(lambda (char*)
(char=? char (remap-alias-char char*)))))
(cond ((or (test-for #\C-h)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/image.scm,v 1.124 1989/08/09 13:17:27 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/image.scm,v 1.125 1989/08/14 09:22:37 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(vector string start start-column parse column-size))))
(define (image-index-size image)
- (- (string-length (image-string image)) (image-start-index image)))
+ (fix:- (string-length (image-string image)) (image-start-index image)))
(define (image-direct-output-insert-char! image char)
(vector-set! image 0 (string-append-char (vector-ref image 0) char))
- (vector-set! image 4 (1+ (vector-ref image 4)))
+ (vector-set! image 4 (fix:1+ (vector-ref image 4)))
unspecific)
(define (image-direct-output-insert-substring! image string start end)
(vector-set! image 0
(string-append-substring (vector-ref image 0)
string start end))
- (vector-set! image 4 (+ (vector-ref image 4) (- end start)))
+ (vector-set! image 4 (fix:+ (vector-ref image 4) (fix:- end start)))
unspecific)
\f
(define (image-representation image)
((string? (car parse))
(let ((size (string-length (car parse))))
(substring-move-right! (car parse) 0 size result result-start)
- (loop (cdr parse) (1+ string-start) (+ result-start size))))
+ (loop (cdr parse)
+ (fix:1+ string-start)
+ (fix:+ result-start size))))
((number? (car parse))
(substring-move-right! string string-start (car parse)
result result-start)
(loop (cdr parse)
(car parse)
- (+ result-start (- (car parse) string-start))))
+ (fix:+ result-start (fix:- (car parse) string-start))))
(else
(error "Bad parse element" (car parse)))))
result)))
(start (image-start-index image))
(column (image-start-column image)))
(cond ((null? parse)
- (+ column (- index start)))
+ (fix:+ column (fix:- index start)))
((string? (car parse))
- (if (= index start)
+ (if (fix:= index start)
column
(loop (cdr parse)
- (1+ start)
- (+ column (string-length (car parse))))))
+ (fix:1+ start)
+ (fix:+ column (string-length (car parse))))))
((number? (car parse))
- (if (<= index (car parse))
- (+ column (- index start))
+ (if (fix:> index (car parse))
(loop (cdr parse)
(car parse)
- (+ column (- (car parse) start)))))
+ (fix:+ column (fix:- (car parse) start)))
+ (fix:+ column (fix:- index start))))
(else
(error "Bad parse element" (car parse))))))
(start (image-start-index image))
(c (image-start-column image)))
(cond ((null? parse)
- (+ start (- column c)))
+ (fix:+ start (fix:- column c)))
((string? (car parse))
- (let ((new-c (+ c (string-length (car parse)))))
- (if (< column new-c)
+ (let ((new-c (fix:+ c (string-length (car parse)))))
+ (if (fix:< column new-c)
start
- (loop (cdr parse) (1+ start) new-c))))
+ (loop (cdr parse) (fix:1+ start) new-c))))
((number? (car parse))
- (let ((new-c (+ c (- (car parse) start))))
- (if (< column new-c)
- (+ start (- column c))
+ (let ((new-c (fix:+ c (fix:- (car parse) start))))
+ (if (fix:< column new-c)
+ (fix:+ start (fix:- column c))
(loop (cdr parse) (car parse) new-c))))
(else
(error "Bad parse element" (car parse))))))
(define (substring-representation string start end start-column)
(let ((result
(string-allocate
- (- (substring-column-length string start end start-column)
+ (fix:- (substring-column-length string start end start-column)
start-column))))
(let loop ((start start) (column start-column) (rindex 0))
(let* ((index
(char-representation (string-ref string index) column))
(size (string-length representation)))
(substring-move-right! representation 0 size result rindex)
- (loop (1+ index) (+ column size) (+ rindex size))))))
+ (loop (fix:1+ index)
+ (fix:+ column size)
+ (fix:+ rindex size))))))
(cond ((not index)
(substring-move-right! string start end result rindex)
result)
- ((= start index)
+ ((fix:= start index)
(copy-representation! column rindex))
(else
(substring-move-right! string start index result rindex)
- (let ((size (- index start)))
- (copy-representation! (+ column size) (+ rindex size)))))))))
-
+ (let ((size (fix:- index start)))
+ (copy-representation! (fix:+ column size)
+ (fix:+ rindex size)))))))))
+\f
(define (string-column-length string start-column)
(substring-column-length string 0 (string-length string) start-column))
(define (string-index->column string start-column index)
- (+ start-column (substring-column-length string 0 index start-column)))
+ (fix:+ start-column (substring-column-length string 0 index start-column)))
(define (substring-column-length string start end start-column)
(let loop ((i start) (c start-column))
(substring-find-next-char-in-set string i end
char-set:not-graphic)))
(if (not index)
- (+ c (- end i))
- (loop (1+ index)
- (let ((c (+ c (- index i))))
- (+ c (char-column-length (string-ref string index) c))))))))
+ (fix:+ c (fix:- end i))
+ (loop (fix:1+ index)
+ (let ((c (fix:+ c (fix:- index i))))
+ (fix:+ c
+ (char-column-length (string-ref string index)
+ c))))))))
(define (string-column->index string start-column column if-lose)
(substring-column->index string 0 (string-length string) start-column
(define (substring-column->index string start end start-column column
#!optional if-lose)
- (if (zero? column)
+ (if (fix:zero? column)
start
- (let loop ((i start) (c start-column) (left (- column start-column)))
+ (let loop ((i start) (c start-column) (left (fix:- column start-column)))
(let ((index
(substring-find-next-char-in-set string i end
char-set:not-graphic)))
(if (not index)
- (let ((n (- end i)))
- (cond ((<= left n) (+ i left))
+ (let ((n (fix:- end i)))
+ (cond ((not (fix:> left n)) (fix:+ i left))
((default-object? if-lose) end)
- (else (if-lose (+ c n)))))
- (let ((n (- index i)))
- (if (<= left n)
- (+ i left)
- (let ((c (+ c n))
- (left (- left n)))
+ (else (if-lose (fix:+ c n)))))
+ (let ((n (fix:- index i)))
+ (if (fix:> left n)
+ (let ((c (fix:+ c n))
+ (left (fix:- left n)))
(let ((n
(char-column-length (string-ref string index) c)))
- (cond ((< left n) index)
- ((= left n) (1+ index))
+ (cond ((fix:< left n) index)
+ ((fix:= left n) (fix:1+ index))
(else
- (loop (1+ index) (+ c n) (- left n)))))))))))))
+ (loop (fix:1+ index)
+ (fix:+ c n)
+ (fix:- left n))))))
+ (fix:+ i left))))))))
\f
;;;; Parsing
(substring-find-next-char-in-set string start end
char-set:not-graphic)))
(if (not index)
- (receiver '() (+ column (- end start)))
- (let ((column (+ column (- index start))))
+ (receiver '() (fix:+ column (fix:- end start)))
+ (let ((column (fix:+ column (fix:- index start))))
(let ((representation
(char-representation (string-ref string index) column)))
- (loop (1+ index)
- (+ column (string-length representation))
+ (loop (fix:1+ index)
+ (fix:+ column (string-length representation))
(lambda (parse column-size)
- (receiver (if (= index start) (cons representation parse)
+ (receiver (if (fix:= index start)
+ (cons representation parse)
(cons index (cons representation parse)))
column-size)))))))))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/keymap.scm,v 1.7 1989/04/28 22:50:37 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/keymap.scm,v 1.8 1989/08/14 09:22:41 cph Rel $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
+(define-command describe-bindings
+ "Show a list of all defined keys, and their definitions.
+The list is put in a buffer, which is displayed."
+ ()
+ (lambda ()
+ (with-output-to-help-display
+ (lambda ()
+ (let ((alists (comtabs->alists (current-comtabs))))
+ (if (not (null? alists))
+ (let ((n
+ (+ (apply max
+ (map (lambda (elements)
+ (apply max
+ (map (lambda (element)
+ (string-length
+ (car element)))
+ elements)))
+ alists))
+ 2)))
+ (let ((write-element
+ (lambda (element)
+ (write-string
+ (string-append (pad-on-right-to (car element) n)
+ " "
+ (cdr element)))
+ (newline))))
+ (let ((write-elements
+ (lambda (elements)
+ (write-element '("key" . "binding"))
+ (write-element '("---" . "-------"))
+ (for-each (lambda (elements)
+ (newline)
+ (for-each write-element elements))
+ (sort-by-prefix elements)))))
+ (write-elements (car alists))
+ (for-each (lambda (elements)
+ (newline)
+ (write-elements elements))
+ (cdr alists)))))))))))
+\f
(define-command make-command-summary
"Make a summary of current key bindings in the buffer *Summary*.
Previous contents of that buffer are killed first."
()
(lambda ()
- (let ((buffer (temporary-buffer "*Summary*")))
- (with-output-to-mark (buffer-point buffer)
- (lambda ()
- (write-keymap
- ""
- (comtab-dispatch-alists
- (car (mode-comtabs (ref-mode-object fundamental)))))))
- (select-buffer buffer)
- (set-current-point! (buffer-start buffer)))))
+ (with-output-to-help-display
+ (lambda ()
+ (let ((alists (comtabs->alists (current-comtabs))))
+ (if (not (null? alists))
+ (begin
+ (write-summary-keymap (car alists))
+ (for-each (lambda (alist)
+ (write-string separator)
+ (write-summary-keymap alist))
+ (cdr alists)))))))))
+
+(define separator
+ "
+===============================================================================
-(define (write-keymap prefix da)
- (for-each (lambda (element)
- (write-string prefix)
- (write-string (pad-on-right-to (char-name (car element)) 9))
- (write-string " ")
- (write-string (command-name-string (cdr element)))
- (newline))
- (sort-by-char (filter-uninteresting (cdr da))))
- (for-each (lambda (element)
- (write-keymap (string-append prefix
- (char-name (car element))
- " ")
- (cdr element)))
- (sort-by-char (car da))))
+")
+
+(define (write-summary-keymap alist)
+ (let ((element-lists (sort-by-prefix alist)))
+ (if (not (null? element-lists))
+ (let loop
+ ((entry (car element-lists))
+ (element-lists (cdr element-lists)))
+ (write-summary-style-elements entry)
+ (if (not (null? element-lists))
+ (begin
+ (newline)
+ (loop (car element-lists) (cdr element-lists))))))))
+
+(define (write-summary-style-elements elements)
+ (let loop ((elements (reorder-list elements)))
+ (if (not (null? elements))
+ (let ((element->string
+ (lambda (element)
+ (string-append
+ (let ((string (car element)))
+ (if (< (string-length string) 9)
+ (pad-on-right-to string 9)
+ (let loop ((n 16))
+ (if (< (string-length string) n)
+ (pad-on-right-to string n)
+ (loop (+ n 8))))))
+ (cdr element)))))
+ (let ((string (element->string (car elements))))
+ (if (null? (cdr elements))
+ (begin
+ (write-string string)
+ (newline))
+ (begin
+ (write-string (pad-on-right-to string 39))
+ (write-char #\space)
+ (write-string (element->string (cadr elements)))
+ (newline)
+ (loop (cddr elements)))))))))
+
+(define (reorder-list items)
+ (let ((tail (list-tail items (integer-ceiling (length items) 2))))
+ (let loop ((items items) (items* tail))
+ (cond ((eq? items tail) '())
+ ((null? items*) (list (car items)))
+ (else
+ (cons* (car items)
+ (car items*)
+ (loop (cdr items) (cdr items*))))))))
+\f
+(define (comtabs->alists comtabs)
+ (let loop ((comtabs comtabs))
+ (cons (sort-and-simplify (comtab->alist (car comtabs)))
+ (if (and (not (null? (cdr comtabs)))
+ (comtab? (cadr comtabs)))
+ (loop (cdr comtabs))
+ '()))))
-(define (uninteresting-element? element)
- (or (char-lower-case? (char-base (car element)))
- (memq (command-name (cdr element))
- '(self-insert-command
- negative-argument
- digit-argument
- auto-negative-argument
- auto-digit-argument
- auto-argument))))
+(define (sort-and-simplify elements)
+ (map (lambda (element)
+ (cons (xchar->name (car element))
+ (command-name-string (cdr element))))
+ (sort elements (lambda (a b) (xchar<? (car a) (car b))))))
-(define (filter-uninteresting items)
- (list-transform-negative items uninteresting-element?))
+(define (sort-by-prefix elements)
+ (let ((prefix-alist '()))
+ (let ((make-entry
+ (lambda (prefix element)
+ (let ((entry
+ (list-search-positive prefix-alist
+ (lambda (entry)
+ (string=? (car entry) prefix)))))
+ (if entry
+ (set-cdr! entry (cons element (cdr entry)))
+ (set! prefix-alist
+ (cons (list prefix element) prefix-alist)))
+ unspecific))))
+ (for-each (lambda (element)
+ (let ((string (car element)))
+ (let ((has-prefix
+ (lambda (index)
+ (make-entry (string-head string index) element)))
+ (index (string-find-previous-char string #\space)))
+ (cond (index
+ (has-prefix (1+ index)))
+ ((string-prefix? "M-C-" string)
+ (has-prefix 4))
+ ((or (string-prefix? "M-" string)
+ (string-prefix? "C-" string))
+ (has-prefix 2))
+ (else
+ (make-entry "" element))))))
+ elements))
+ (map (lambda (entry)
+ (group-elements (reverse! (cdr entry))))
+ (sort prefix-alist (lambda (x y) (string<? (car x) (car y)))))))
-(define (sort-by-char elements)
- (sort elements
- (lambda (a b)
- (char<? (car a) (car b)))))
\ No newline at end of file
+(define (group-elements elements)
+ (if (or (null? elements)
+ (null? (cdr elements)))
+ elements
+ (let ((command-name (cdar elements)))
+ (if (string=? command-name (cdadr elements))
+ (let ((last
+ (let loop ((elements (cdr elements)))
+ (if (or (null? (cdr elements))
+ (not (string=? command-name (cdadr elements))))
+ elements
+ (loop (cdr elements))))))
+ (cons (cons (string-append (caar elements)
+ " .. "
+ (caar last))
+ command-name)
+ (group-elements (cdr last))))
+ (cons (car elements) (group-elements (cdr elements)))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/loadef.scm,v 1.5 1989/08/03 23:32:32 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/loadef.scm,v 1.6 1989/08/14 09:22:45 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define-autoload-command 'make-command-summary 'COMMAND-SUMMARY
"Make a summary of current key bindings in the buffer *Summary*.
Previous contents of that buffer are killed first.")
+
+(define-autoload-command 'describe-bindings 'COMMAND-SUMMARY
+ "Show a list of all defined keys, and their definitions.
+The list is put in a buffer, which is displayed.")
+
(define-library 'RESTRICT-SCREEN
'("rescrn" (EDWIN WINDOW)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.121 1989/08/12 08:32:28 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.122 1989/08/14 09:22:49 cph Exp $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
(define-key 'fundamental #\rubout 'backward-delete-char)
\f
-(define-key 'fundamental #\c-space 'set-mark-command)
(define-key 'fundamental #\c-% 'replace-string)
(define-key 'fundamental #\c-- 'negative-argument)
(define-key 'fundamental #\c-0 'digit-argument)
\f
(define-key 'fundamental '(#\c-c #\c-s) 'select-transcript-buffer)
-(define-key 'fundamental '(#\c-h #\a) 'command-apropos)(define-key 'fundamental '(#\c-h #\c) 'describe-key-briefly)
+(define-key 'fundamental '(#\c-h #\a) 'command-apropos)
+(define-key 'fundamental '(#\c-h #\b) 'describe-bindings)
+(define-key 'fundamental '(#\c-h #\c) 'describe-key-briefly)
(define-key 'fundamental '(#\c-h #\f) 'describe-command)
(define-key 'fundamental '(#\c-h #\i) 'info)
(define-key 'fundamental '(#\c-h #\k) 'describe-key)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/motion.scm,v 1.80 1989/04/28 22:51:47 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/motion.scm,v 1.81 1989/08/14 09:22:53 cph Exp $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
(if (group-end-index? group index)
(limit-mark-motion (and (not (default-object? limit?)) limit?)
(group-end-mark group))
- (make-mark group (1+ index)))))
+ (make-mark group (fix:1+ index)))))
(define (mark-1+ mark #!optional limit?)
(let ((group (mark-group mark))
(if (group-start-index? group index)
(limit-mark-motion (and (not (default-object? limit?)) limit?)
(group-start-mark group))
- (make-mark group (-1+ index)))))
+ (make-mark group (fix:-1+ index)))))
(define (region-count-chars region)
- (- (region-end-index region) (region-start-index region)))
+ (fix:- (region-end-index region) (region-start-index region)))
(define mark+)
(define mark-)
(set! mark+
(named-lambda (mark+ mark n #!optional limit?)
(let ((limit? (and (not (default-object? limit?)) limit?)))
- (cond ((positive? n) (%mark+ mark n limit?))
- ((negative? n) (%mark- mark (- n) limit?))
+ (cond ((fix:positive? n) (%mark+ mark n limit?))
+ ((fix:negative? n) (%mark- mark (fix:- 0 n) limit?))
(else mark)))))
(set! mark-
(named-lambda (mark- mark n #!optional limit?)
(let ((limit? (and (not (default-object? limit?)) limit?)))
- (cond ((positive? n) (%mark- mark n limit?))
- ((negative? n) (%mark+ mark (- n) limit?))
+ (cond ((fix:positive? n) (%mark- mark n limit?))
+ ((fix:negative? n) (%mark+ mark (fix:- 0 n) limit?))
(else mark)))))
(define (%mark+ mark n limit?)
(let ((group (mark-group mark))
- (new-index (+ (mark-index mark) n)))
- (if (> new-index (group-end-index group))
+ (new-index (fix:+ (mark-index mark) n)))
+ (if (fix:> new-index (group-end-index group))
(limit-mark-motion limit? (group-end-mark group))
(make-mark group new-index))))
(define (%mark- mark n limit?)
(let ((group (mark-group mark))
- (new-index (- (mark-index mark) n)))
- (if (< new-index (group-start-index group))
+ (new-index (fix:- (mark-index mark) n)))
+ (if (fix:< new-index (group-start-index group))
(limit-mark-motion limit? (group-start-mark group))
(make-mark group new-index))))
;;; the limiting mark (the group's start or end) which was exceeded.
(define (move-vertically group index n if-ok if-not-ok)
- (cond ((positive? n)
+ (cond ((fix:positive? n)
(let ((limit (group-end-index group)))
(let loop ((i index) (n n))
(let ((j (%find-next-newline group i limit)))
(cond ((not j) (if-not-ok (group-end-mark group)))
- ((= n 1) (if-ok (1+ j)))
- (else (loop (1+ j) (-1+ n))))))))
- ((negative? n)
+ ((fix:= n 1) (if-ok (fix:1+ j)))
+ (else (loop (fix:1+ j) (fix:-1+ n))))))))
+ ((fix:negative? n)
(let ((limit (group-start-index group)))
(let loop ((i index) (n n))
(let ((j (%find-previous-newline group i limit)))
- (cond ((zero? n) (if-ok (or j limit)))
+ (cond ((fix:zero? n) (if-ok (or j limit)))
((not j) (if-not-ok (group-start-mark group)))
- (else (loop (-1+ j) (1+ n))))))))
+ (else (loop (fix:-1+ j) (fix:1+ n))))))))
(else
(if-ok (line-start-index group index)))))
(define (group-count-lines group start end)
(let loop ((start start) (n 0))
- (if (= start end)
+ (if (fix:= start end)
n
(let ((i (%find-next-newline group start end))
- (n (1+ n)))
+ (n (fix:1+ n)))
(if (not i)
n
- (loop (1+ i) n))))))
+ (loop (fix:1+ i) n))))))
\f
;;;; Motion by Columns
(group-column-length group (line-start-index group index) index 0))
(define (group-column-length group start-index end-index start-column)
- (if (= start-index end-index)
+ (if (fix:= start-index end-index)
0
(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))
+ (if (and (not (fix:> start gap-start))
+ (not (fix:> gap-end end)))
(substring-column-length text gap-end end
(substring-column-length text start gap-start start-column))
(substring-column-length text start end start-column)))))
(define (group-column->index group start-index end-index start-column column)
- (if (= start-index end-index)
+ (if (fix:= start-index end-index)
start-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)))
- (cond ((<= end gap-start)
+ (cond ((not (fix:> end gap-start))
(substring-column->index text start end start-column column))
- ((>= start gap-end)
- (- (substring-column->index text start end start-column column)
- (group-gap-length group)))
+ ((not (fix:< start gap-end))
+ (fix:- (substring-column->index text start end
+ start-column column)
+ (group-gap-length group)))
(else
(substring-column->index text start gap-start
start-column column
(lambda (gap-column)
- (- (substring-column->index text gap-end end
- gap-column column)
- (group-gap-length group)))))))))
\ No newline at end of file
+ (fix:- (substring-column->index text gap-end end
+ gap-column column)
+ (group-gap-length group)))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/struct.scm,v 1.70 1989/08/11 11:50:48 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/struct.scm,v 1.71 1989/08/14 09:23:01 cph Exp $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
group))
(define (group-length group)
- (- (string-length (group-text group)) (group-gap-length group)))
+ (fix:- (string-length (group-text group)) (group-gap-length group)))
(define-integrable (group-start-index group)
(mark-index (group-start-mark group)))
(mark-index (group-end-mark group)))
(define-integrable (group-start-index? group index)
- (<= index (group-start-index group)))
+ (not (fix:> index (group-start-index group))))
(define-integrable (group-end-index? group index)
- (>= index (group-end-index group)))
+ (not (fix:< index (group-end-index group))))
(define-integrable (set-group-read-only! group)
(vector-set! group group-index:read-only? true)
(%make-region (group-start-mark group) (group-end-mark group)))
\f
(define (group-position->index group position)
- (if (> position (group-gap-end group))
- (- position (group-gap-length group))
+ (if (fix:> position (group-gap-end group))
+ (fix:- position (group-gap-length group))
(let ((start (group-gap-start group)))
- (if (> position start)
+ (if (fix:> position start)
start
position))))
(define (group-index->position group index left-inserting?)
(let ((start (group-gap-start group)))
- (cond ((< index start) index)
- ((> index start) (+ index (group-gap-length group)))
+ (cond ((fix:< index start) index)
+ ((fix:> index start) (fix:+ index (group-gap-length group)))
(left-inserting? (group-gap-end group))
(else start))))
(group-index->position group index left-inserting?)
left-inserting?))
-(define-integrable (mark-index mark)
- (group-position->index (mark-group mark) (mark-position mark)))
-
+(define (mark-index mark)
+ ;; Open-coded for speed -- this procedure is called -alot-.
+ ;; (group-position->index (mark-group mark) (mark-position mark))
+ (let ((group (mark-group mark))
+ (position (mark-position mark)))
+ (if (fix:> position (group-gap-end group))
+ (fix:- position (group-gap-length group))
+ (let ((start (group-gap-start group)))
+ (if (fix:> position start)
+ start
+ position)))))
+\f
(define-integrable (mark~ mark1 mark2)
(eq? (mark-group mark1) (mark-group mark2)))
;;; indexes of the marks. But this implementation is faster and will
;;; only fail when marks are used improperly.
-(define-integrable (mark= mark1 mark2)
+(define (mark= mark1 mark2)
(and (mark~ mark1 mark2)
- (= (mark-position mark1) (mark-position mark2))))
+ (fix:= (mark-position mark1) (mark-position mark2))))
-(define-integrable (mark/= mark1 mark2)
+(define (mark/= mark1 mark2)
(and (mark~ mark1 mark2)
- (not (= (mark-position mark1) (mark-position mark2)))))
+ (not (fix:= (mark-position mark1) (mark-position mark2)))))
-(define-integrable (mark< mark1 mark2)
+(define (mark< mark1 mark2)
(and (mark~ mark1 mark2)
- (< (mark-position mark1) (mark-position mark2))))
+ (fix:< (mark-position mark1) (mark-position mark2))))
-(define-integrable (mark<= mark1 mark2)
+(define (mark<= mark1 mark2)
(and (mark~ mark1 mark2)
- (<= (mark-position mark1) (mark-position mark2))))
+ (not (fix:> (mark-position mark1) (mark-position mark2)))))
-(define-integrable (mark> mark1 mark2)
+(define (mark> mark1 mark2)
(and (mark~ mark1 mark2)
- (> (mark-position mark1) (mark-position mark2))))
+ (fix:> (mark-position mark1) (mark-position mark2))))
-(define-integrable (mark>= mark1 mark2)
+(define (mark>= mark1 mark2)
(and (mark~ mark1 mark2)
- (>= (mark-position mark1) (mark-position mark2))))
+ (not (fix:< (mark-position mark1) (mark-position mark2)))))
(define-integrable (group-start mark)
(group-start-mark (mark-group mark)))
(define-integrable (group-end mark)
(group-end-mark (mark-group mark)))
-(define-integrable (group-start? mark)
- (<= (mark-position mark) (mark-position (group-start mark))))
+(define (group-start? mark)
+ (not (fix:> (mark-position mark) (mark-position (group-start mark)))))
-(define-integrable (group-end? mark)
- (>= (mark-position mark) (mark-position (group-end mark))))
+(define (group-end? mark)
+ (not (fix:< (mark-position mark) (mark-position (group-end mark)))))
\f
(define (mark-right-inserting mark)
(if (mark-left-inserting? mark)
(let ((group (mark-group mark)))
(%%make-permanent-mark group
(let ((position (mark-position mark)))
- (if (= position (group-gap-end group))
+ (if (fix:= position (group-gap-end group))
(group-gap-start group)
position))
false))
(let ((group (mark-group mark)))
(%%make-permanent-mark group
(let ((position (mark-position mark)))
- (if (= position (group-gap-start group))
+ (if (fix:= position (group-gap-start group))
(group-gap-end group)
position))
true))))
((and (if (mark-left-inserting? mark)
left-inserting?
(not left-inserting?))
- (= (mark-position mark) position))
+ (fix:= (mark-position mark) position))
mark)
(else
(set-group-marks! group marks)
((and (if (mark-left-inserting? mark)
left-inserting?
(not left-inserting?))
- (= (mark-position mark) position))
+ (fix:= (mark-position mark) position))
mark)
(else
(scan-tail marks (system-pair-cdr marks)))))))
(if (and (if (mark-left-inserting? mark)
left-inserting?
(not left-inserting?))
- (= (mark-position mark) position))
+ (fix:= (mark-position mark) position))
mark
(scan-tail marks (system-pair-cdr marks))))))))
((and (if (mark-left-inserting? mark)
left-inserting?
(not left-inserting?))
- (= (mark-position mark) position))
+ (fix:= (mark-position mark) position))
mark)
(else
(scan-tail marks (system-pair-cdr marks))))))))
(define-integrable region-end cdr)
(define (make-region start end)
- (cond ((mark<= start end) (%make-region start end))
- ((mark<= end start) (%make-region end start))
- (else (error "Marks not related" start end))))
+ (let ((group (mark-group start))
+ (start-position (mark-position start))
+ (end-position (mark-position end)))
+ (cond ((not (eq? group (mark-group end)))
+ (error "Marks not related" start end))
+ ((not (fix:> start-position end-position))
+ (%make-region start end))
+ (else
+ (%make-region end start)))))
+
(define-integrable (region-group region)
(mark-group (region-start region)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.18 1989/08/12 08:32:42 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.19 1989/08/14 09:23:05 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(loop (cdr strings) string* index*)
(loop (cdr strings) string index)))))))
-(define (xchar->name char)
- (if (pair? char)
- (chars->name char)
- (char-name char)))
-
-(define (chars->name chars)
- (if (null? chars)
- ""
- (string-append-separated (char-name (car chars))
- (chars->name (cdr chars)))))
-
(define (string-append-separated x y)
(cond ((string-null? x) y)
((string-null? y) x)
(else (string-append x " " y))))
+
+(define (list-of-type? object type)
+ (let loop ((object object))
+ (if (null? object)
+ true
+ (and (pair? object)
+ (type (car object))
+ (loop (cdr object))))))
+
(define (dotimes n procedure)
(define (loop i)
(if (< i n)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utlwin.scm,v 1.53 1989/08/08 11:12:29 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utlwin.scm,v 1.54 1989/08/14 09:23:08 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(cond ((not (cdr representation))
;; disable clipping.
(subscreen-clear! screen
- x-start (+ x-start xu)
- y-start (+ y-start yu))
+ x-start (fix:+ x-start xu)
+ y-start (fix:+ y-start yu))
#|
(subscreen-clear! screen
- (+ x-start xl) (+ x-start xu)
- (+ y-start yl) (+ y-start yu))
+ (fix:+ x-start xl) (fix:+ x-start xu)
+ (fix:+ y-start yl) (fix:+ y-start yu))
|#
)
- ((< yl yu)
+ ((fix:< yl yu)
(let ((start (cdr representation))
(end (string-length (car representation)))
- (ayu (+ y-start yu)))
+ (ayu (fix:+ y-start yu)))
;; disable clipping.
- (if (not (zero? start))
+ (if (not (fix:zero? start))
(subscreen-clear! screen
- x-start (+ x-start start)
+ x-start (fix:+ x-start start)
y-start ayu))
(screen-write-substring! screen
- (+ x-start start) y-start
+ (fix:+ x-start start) y-start
(car representation)
start end)
- (if (< end x-size)
+ (if (fix:< end x-size)
(subscreen-clear! screen
- (+ x-start end) (+ x-start x-size)
- y-start ayu))
+ (fix:+ x-start end)
+ (fix:+ x-start x-size)
+ y-start
+ ayu))
#|
- (if (not (zero? start))
+ (if (not (fix:zero? start))
(clip-window-region-1 xl xu start
(lambda (xl xu)
(subscreen-clear! screen
- (+ x-start xl) (+ x-start xu)
- ayl ayu))))
- (clip-window-region-1 (- xl start) (- xu start) (- end start)
+ (fix:+ x-start xl)
+ (fix:+ x-start xu)
+ ayl
+ ayu))))
+ (clip-window-region-1 (fix:- xl start)
+ (fix:- xu start)
+ (fix:- end start)
(lambda (xl xu)
- (let ((xl* (+ xl start)))
+ (let ((xl* (fix:+ xl start)))
(screen-write-substring! screen
- (+ x-start xl*) ayl
+ (fix:+ x-start xl*) ayl
(car representation)
- xl* (+ xu start)))))
- (clip-window-region-1 (- xl end) (- xu end) (- x-size end)
+ xl* (fix:+ xu start)))))
+ (clip-window-region-1 (fix:- xl end)
+ (fix:- xu end)
+ (fix:- x-size end)
(lambda (xl xu)
- (let ((x-start (+ x-start end)))
+ (let ((x-start (fix:+ x-start end)))
(subscreen-clear! screen
- (+ x-start xl) (+ x-start xu)
+ (fix:+ x-start xl) (fix:+ x-start xu)
ayl ayu))))
|#
))))
(else
- (screen-write-substrings! screen (+ x-start xl) (+ y-start yl)
+ (screen-write-substrings! screen (fix:+ x-start xl) (fix:+ y-start yl)
representation xl xu yl yu)))
true)
\f
(with-instance-variables string-base window (x y)
(image-column->index image
(let ((column-size (image-column-size image)))
- (if (and truncate-lines? (= x (-1+ x-size)))
+ (if (and truncate-lines? (fix:= x (fix:-1+ x-size)))
column-size
(min (coordinates->column x y x-size)
column-size))))))
(if truncate-lines?
column-size
(let ((qr (integer-divide column-size y-size)))
- (if (zero? (integer-divide-remainder qr))
+ (if (fix:zero? (integer-divide-remainder qr))
(integer-divide-quotient qr)
- (1+ (integer-divide-quotient qr))))))
+ (fix:1+ (integer-divide-quotient qr))))))
(define (column->y-size column-size x-size truncate-lines?)
;; Assume X-SIZE > 1.
- (if (or truncate-lines? (zero? column-size))
+ (if (or truncate-lines? (fix:zero? column-size))
1
- (let ((qr (integer-divide column-size (-1+ x-size))))
- (if (zero? (integer-divide-remainder qr))
+ (let ((qr (integer-divide column-size (fix:-1+ x-size))))
+ (if (fix:zero? (integer-divide-remainder qr))
(integer-divide-quotient qr)
- (1+ (integer-divide-quotient qr))))))
+ (fix:1+ (integer-divide-quotient qr))))))
(define (column->coordinates column-size x-size truncate-lines? column)
- (let ((-1+x-size (-1+ x-size)))
- (cond ((< column -1+x-size)
+ (let ((-1+x-size (fix:-1+ x-size)))
+ (cond ((fix:< column -1+x-size)
(cons column 0))
(truncate-lines?
(cons -1+x-size 0))
(else
(let ((qr (integer-divide column -1+x-size)))
- (if (and (zero? (integer-divide-remainder qr))
- (= column column-size))
+ (if (and (fix:zero? (integer-divide-remainder qr))
+ (fix:= column column-size))
(cons -1+x-size
- (-1+ (integer-divide-quotient qr)))
+ (fix:-1+ (integer-divide-quotient qr)))
(cons (integer-divide-remainder qr)
(integer-divide-quotient qr))))))))
(define (column->x column-size x-size truncate-lines? column)
- (let ((-1+x-size (-1+ x-size)))
- (cond ((< column -1+x-size)
+ (let ((-1+x-size (fix:-1+ x-size)))
+ (cond ((fix:< column -1+x-size)
column)
(truncate-lines?
-1+x-size)
(else
(let ((r (remainder column -1+x-size)))
- (if (and (zero? r) (= column column-size))
+ (if (and (fix:zero? r) (fix:= column column-size))
-1+x-size
r))))))
(define (column->y column-size x-size truncate-lines? column)
(if truncate-lines?
0
- (let ((-1+x-size (-1+ x-size)))
- (if (< column -1+x-size)
+ (let ((-1+x-size (fix:-1+ x-size)))
+ (if (fix:< column -1+x-size)
0
(let ((qr (integer-divide column -1+x-size)))
- (if (and (zero? (integer-divide-remainder qr))
- (= column column-size))
- (-1+ (integer-divide-quotient qr))
+ (if (and (fix:zero? (integer-divide-remainder qr))
+ (fix:= column column-size))
+ (fix:-1+ (integer-divide-quotient qr))
(integer-divide-quotient qr)))))))
(define-integrable (coordinates->column x y x-size)
- (+ x (* y (-1+ x-size))))
+ (fix:+ x (fix:* y (fix:-1+ x-size))))
\f
(define (string-base:direct-output-insert-char! window x char)
(with-instance-variables string-base window (x char)
(if (and (not (cdr representation))
(not (char=? char #\Space)))
(set-cdr! representation x)))
- (string-set! (vector-ref representation (-1+ y-size)) x char))))
+ (string-set! (vector-ref representation (fix:-1+ y-size)) x char))))
(define (string-base:direct-output-insert-newline! window)
(with-instance-variables string-base window ()
(substring-find-next-char-in-set string start end
char-set:not-space)))
(if index
- (set-cdr! representation (+ x index))))))
+ (set-cdr! representation (fix:+ x index))))))
(substring-move-right! string start end
- (vector-ref representation (-1+ y-size)) x))))
+ (vector-ref representation (fix:-1+ y-size))
+ x))))
(define (string-base:refresh! window)
(with-instance-variables string-base window ()
(setup-redisplay-flags! redisplay-flags)))))
(let* ((string (image-representation image))
(column-size (string-length string)))
- (cond ((< column-size x-size)
+ (cond ((fix:< column-size x-size)
(one-liner string))
(truncate-lines?
(one-liner
(let ((s (string-allocate x-size))
- (x-max (-1+ x-size)))
+ (x-max (fix:-1+ x-size)))
(substring-move-right! string 0 x-max s 0)
(string-set! s x-max #\$)
s)))
(else
(let ((rep (make-vector y-size '()))
- (x-max (-1+ x-size)))
+ (x-max (fix:-1+ x-size)))
(let loop ((start 0) (y 0))
(let ((s (string-allocate x-size))
- (end (+ start x-max)))
+ (end (fix:+ start x-max)))
(vector-set! rep y s)
- (if (<= column-size end)
+ (if (fix:> column-size end)
+ (begin
+ (substring-move-right! string start end s 0)
+ (string-set! s x-max #\\)
+ (loop end (fix:1+ y)))
(begin
(substring-move-right! string start column-size s 0)
(substring-fill! s
- (- column-size start)
+ (fix:- column-size start)
x-size
- #\space))
- (begin
- (substring-move-right! string start end s 0)
- (string-set! s x-max #\\)
- (loop end (1+ y))))))
+ #\space)))))
(set! representation rep)
(setup-redisplay-flags! redisplay-flags)))))))
\f
xl xu yl yu display-style)
window display-style ;ignore
(subscreen-clear! screen
- (+ x-start xl) (+ x-start xu)
- (+ y-start yl) (+ y-start yu))
+ (fix:+ x-start xl) (fix:+ x-start xu)
+ (fix:+ y-start yl) (fix:+ y-start yu))
true)
;;;; Vertical Border Window
(error "Can't change the x-size of a vertical border window" x))
(define-method vertical-border-window (:set-size! window x y)
- (if (not (= x 1))
+ (if (not (fix:= x 1))
(error "x-size of a vertical border window must be 1" x))
(set! x-size x)
(set! y-size y)
(:update-display! window screen x-start y-start
xl xu yl yu display-style)
display-style ;ignore
- (if (< xl xu)
+ (if (fix:< xl xu)
(clip-window-region-1 yl yu y-size
(lambda (yl yu)
- (let ((xl (+ x-start xl))
- (yu (+ y-start yu)))
- (let loop ((y (+ y-start yl)))
- (if (< y yu)
+ (let ((xl (fix:+ x-start xl))
+ (yu (fix:+ y-start yu)))
+ (let loop ((y (fix:+ y-start yl)))
+ (if (fix:< y yu)
(begin
(screen-write-char! screen xl y #\|)
- (loop (1+ y)))))))))
+ (loop (fix:1+ y)))))))))
true)
\f
;;;; Cursor Window
(define-method cursor-window (:update-display! window screen x-start y-start
xl xu yl yu display-style)
display-style ;ignore
- (if (and enabled? (< xl xu) (< yl yu)) (screen-write-cursor! screen x-start y-start))
+ (if (and enabled? (fix:< xl xu) (fix:< yl yu))
+ (screen-write-cursor! screen x-start y-start))
true)
(define-method cursor-window (:enable! window)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/window.scm,v 1.149 1989/08/10 05:07:43 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/window.scm,v 1.150 1989/08/14 09:23:13 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
yi (window-y-size window)
(lambda (xl xu yl yu)
(=> window :update-display!
- screen (+ x-start xi) (+ y-start yi)
+ screen (fix:+ x-start xi) (fix:+ y-start yi)
xl xu yl yu display-style)))
(continue))
(continue))))))))
(define (clip-window-region xl xu yl yu xi xs yi ys receiver)
- (clip-window-region-1 (- xl xi) (- xu xi) xs
+ (clip-window-region-1 (fix:- xl xi) (fix:- xu xi) xs
(lambda (xl xu)
- (clip-window-region-1 (- yl yi) (- yu yi) ys
+ (clip-window-region-1 (fix:- yl yi) (fix:- yu yi) ys
(lambda (yl yu)
(receiver xl xu yl yu))))))
(define (clip-window-region-1 al au bs receiver)
- (if (positive? al)
- (if (<= al bs)
- (receiver al (if (< bs au) bs au))
- true)
- (if (positive? au)
- (receiver 0 (if (< bs au) bs au))
+ (if (fix:positive? al)
+ (if (fix:> al bs)
+ true
+ (receiver al (if (fix:< bs au) bs au)))
+ (if (fix:positive? au)
+ (receiver 0 (if (fix:< bs au) bs au))
true)))
(define (salvage-inferiors! window)
(let ((x-start (inferior-x-start inferior))
(y-start (inferior-y-start inferior)))
(if (and x-start y-start)
- (let ((x (- x x-start))
- (y (- y y-start)))
- (if (and (not (negative? x))
- (< x (inferior-x-size inferior))
- (not (negative? y))
- (< y (inferior-y-size inferior)))
+ (let ((x (fix:- x x-start))
+ (y (fix:- y y-start)))
+ (if (and (not (fix:negative? x))
+ (fix:< x (inferior-x-size inferior))
+ (not (fix:negative? y))
+ (fix:< y (inferior-y-size inferior)))
(search (inferior-window inferior) x y)
(loop (cdr inferiors))))
(loop (cdr inferiors))))))))))
(define (inferior-x-end inferior)
(let ((x-start (inferior-x-start inferior)))
(and x-start
- (+ x-start (inferior-x-size inferior)))))
+ (fix:+ x-start (inferior-x-size inferior)))))
(define (set-inferior-x-end! inferior x-end)
- (set-inferior-x-start! inferior (- x-end (inferior-x-size inferior))))
+ (set-inferior-x-start! inferior (fix:- x-end (inferior-x-size inferior))))
(define-integrable (inferior-y-start inferior)
(vector-ref (cdr inferior) 1))
(define (inferior-y-end inferior)
(let ((y-start (inferior-y-start inferior)))
(and y-start
- (+ y-start (inferior-y-size inferior)))))
+ (fix:+ y-start (inferior-y-size inferior)))))
(define (set-inferior-y-end! inferior y-end)
- (set-inferior-y-start! inferior (- y-end (inferior-y-size inferior))))
+ (set-inferior-y-start! inferior (fix:- y-end (inferior-y-size inferior))))
+
(define (inferior-start inferior receiver)
(receiver (inferior-x-start inferior)
(inferior-y-start inferior)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rgxcmp.scm,v 1.101 1989/04/28 22:52:50 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rgxcmp.scm,v 1.102 1989/08/14 09:22:56 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define (re-compile-string string case-fold?)
(let ((string (if case-fold? (string-upcase string) string)))
(let ((n (string-length string)))
- (if (zero? n)
+ (if (fix:zero? n)
string
(let ((result
(string-allocate
(let ((qr (integer-divide n 255)))
- (+ (* 257 (integer-divide-quotient qr))
- (cond ((zero? (integer-divide-remainder qr)) 0)
- ((= 1 (integer-divide-remainder qr)) 2)
- (else (+ (integer-divide-remainder qr) 2))))))))
+ (fix:+ (fix:* 257 (integer-divide-quotient qr))
+ (let ((r (integer-divide-remainder qr)))
+ (cond ((fix:zero? r) 0)
+ ((fix:= 1 r) 2)
+ (else (fix:+ r 2)))))))))
(let loop ((n n) (i 0) (p 0))
- (cond ((= n 1)
+ (cond ((fix:= n 1)
(vector-8b-set! result p re-code:exact-1)
- (vector-8b-set! result (1+ p) (vector-8b-ref string i))
+ (vector-8b-set! result
+ (fix:1+ p)
+ (vector-8b-ref string i))
result)
- ((< n 256)
+ ((fix:< n 256)
(vector-8b-set! result p re-code:exact-n)
- (vector-8b-set! result (1+ p) n)
- (substring-move-right! string i (+ i n) result (+ p 2))
+ (vector-8b-set! result (fix:1+ p) n)
+ (substring-move-right! string i (fix:+ i n)
+ result (fix:+ p 2))
result)
(else
(vector-8b-set! result p re-code:exact-n)
- (vector-8b-set! result (1+ p) 255)
- (let ((j (+ i 255)))
- (substring-move-right! string i j result (+ p 2))
- (loop (- n 255) j (+ p 257)))))))))))
+ (vector-8b-set! result (fix:1+ p) 255)
+ (let ((j (fix:+ i 255)))
+ (substring-move-right! string i j result (fix:+ p 2))
+ (loop (fix:- n 255) j (fix:+ p 257)))))))))))
\f
;;;; Char-Set Compiler
(begin
(let ((end (char->ascii (caddr pattern))))
(let loop ((index (char->ascii (car pattern))))
- (if (< index end)
+ (if (fix:< index end)
(begin
(vector-8b-set! char-set
index
foreground)
- (loop (1+ index))))))
+ (loop (fix:1+ index))))))
(loop (cdddr pattern)))
(error "RE-COMPILE-CHAR-SET: Terminating hyphen")))
(else
(adjoin! (char->ascii (car pattern)))
(loop (cdr pattern)))))))))
- (if (and (not (zero? length))
+ (if (and (not (fix:zero? length))
(char=? (string-ref pattern 0) #\^))
(if negate?
(kernel 1 0 1)
(let ((tail (list byte)))
(set-cdr! output-tail tail)
(set! output-tail tail))
- (set! output-length (1+ output-length))
+ (set! output-length (fix:1+ output-length))
unspecific)
(define-integrable (output-re-code! code)
(lambda (low high)
(set-cdr! (cdr from)
(cons* opcode low high (cddr from)))
- (set! output-length (+ output-length 3))
+ (set! output-length (fix:+ output-length 3))
unspecific)))
(define (compute-jump from to receiver)
- (let ((n (- to (+ from 3))))
- (let ((qr (integer-divide (if (negative? n) (+ n #x10000) n) #x100)))
+ (let ((n (fix:- to (fix:+ from 3))))
+ (let ((qr
+ (integer-divide (if (fix:negative? n) (fix:+ n #x10000) n)
+ #x100)))
(receiver (integer-divide-remainder qr)
(integer-divide-quotient qr)))))
\f
(null? stack))
(define-integrable (stack-full?)
- (>= (stack-length) stack-maximum-length))
+ (not (fix:< (stack-length) stack-maximum-length)))
(define-integrable (stack-length)
(length stack))
(output! (input-peek-1)))
(begin
(if (or (not pending-exact)
- (= (pointer-ref pending-exact) #x7F))
+ (fix:= (pointer-ref pending-exact) #x7F))
(begin
(set! last-start (output-pointer))
(output! re-code:exact-n)
;; More than one repetition allowed: put in a backward jump at
;; the end.
(compute-jump (output-position)
- (- (pointer-position last-start) 3)
+ (fix:- (pointer-position last-start) 3)
(lambda (low high)
(output-re-code! re-code:maybe-finalize-jump)
(output! low)
(output! high))))
(insert-jump! last-start
re-code:on-failure-jump
- (+ (output-position) 3))
+ (fix:+ (output-position) 3))
(if (not zero?)
;; At least one repetition required: insert before the loop a
;; skip over the initial on-failure-jump instruction.
(insert-jump! last-start
re-code:dummy-failure-jump
- (+ (pointer-position last-start) 6))))
+ (fix:+ (pointer-position last-start) 6))))
(define-repeater-char #\* true true)
(define-repeater-char #\+ false true)
(let ((char* (input-peek)))
(input-discard!)
(let loop ((char char))
- (if (<= char char*)
+ (if (not (fix:> char char*))
(begin
((ucode-primitive re-char-set-adjoin!) charset
char)
- (loop (1+ char))))))))
+ (loop (fix:1+ char))))))))
(else
((ucode-primitive re-char-set-adjoin!) charset char))))
(loop))
;; Discard any bitmap bytes that are all 0 at the end of
;; the map. Decrement the map-length byte too.
(define (trim n)
- (cond ((not (zero? (vector-8b-ref charset n)))
- (output! (1+ n))
+ (cond ((not (fix:zero? (vector-8b-ref charset n)))
+ (output! (fix:1+ n))
(let loop ((i 0))
(output! (vector-8b-ref charset i))
- (if (< i n)
- (loop (1+ i)))))
- ((zero? n)
+ (if (fix:< i n)
+ (loop (fix:1+ i)))))
+ ((fix:zero? n)
(output! 0))
(else
- (trim (-1+ n)))))
+ (trim (fix:-1+ n)))))
(vector-8b-fill! charset 0 32 0)
(cond ((input-end?) (premature-end))
(lambda ()
(if (stack-full?)
(error error-type:re-compile-pattern "Nesting too deep"))
- (if (< register-number re-number-of-registers)
+ (if (fix:< register-number re-number-of-registers)
(begin
(output-re-code! re-code:start-memory)
(output! register-number)))
begin-alternative)
(set! last-start false)
(set! fixup-jump false)
- (set! register-number (1+ register-number))
+ (set! register-number (fix:1+ register-number))
(set! begin-alternative (output-pointer))
unspecific))
(set! last-start op)
(set! fixup-jump fj)
(set! begin-alternative bg)
- (if (< rn re-number-of-registers)
+ (if (fix:< rn re-number-of-registers)
(begin
(output-re-code! re-code:stop-memory)
(output! rn)))))))
(lambda ()
(insert-jump! begin-alternative
re-code:on-failure-jump
- (+ (output-position) 6))
+ (fix:+ (output-position) 6))
(if fixup-jump
(store-jump! fixup-jump re-code:jump (output-position)))
(set! fixup-jump (output-pointer))
(let ((char (digit->char digit)))
(define-backslash-char char
(lambda ()
- (if (>= digit register-number)
- (normal-char)
+ (if (fix:< digit register-number)
(let ((n (stack-length)))
(let search-stack ((i 0))
- (cond ((>= i n)
+ (cond ((not (fix:< i n))
(output-start! re-code:duplicate)
(output! digit))
- ((= (stack-ref-register-number i) digit)
+ ((fix:= (stack-ref-register-number i) digit)
(normal-char))
(else
- (search-stack (1+ i)))))))))))
+ (search-stack (fix:1+ i))))))
+ (normal-char))))))
+
(for-each define-digit-char '(1 2 3 4 5 6 7 8 9))
\f
;;;; Compiled Pattern Disassembler
projects / mit-scheme.git / commitdiff