From c78a8eaccc17438afb09153ed72f542c84e05134 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 14 Aug 1989 09:23:13 +0000 Subject: [PATCH] * Rewrite core group operations, image operations, window operations, and the regular-expression compiler to use fixnum arithmetic. This has a pronounced performance effect. * Change "decls" to pass integrable-procedure definitions between a few crucial files. * New variable `enable-emacs-key-names' controls whether keys are displayed using Emacs-style names or Scheme-style names. The default is Emacs-style. * C-h C-b now runs `describe-bindings' as in Emacs. --- v7/src/edwin/bufwfs.scm | 62 ++++---- v7/src/edwin/bufwin.scm | 123 ++++++++-------- v7/src/edwin/bufwiu.scm | 146 ++++++++++--------- v7/src/edwin/bufwmc.scm | 60 ++++---- v7/src/edwin/calias.scm | 73 +++++++++- v7/src/edwin/comtab.scm | 15 +- v7/src/edwin/decls.scm | 292 +++++++++++++++++++++++--------------- v7/src/edwin/edwin.pkg | 3 +- v7/src/edwin/grpops.scm | 136 +++++++++--------- v7/src/edwin/hlpcom.scm | 36 ++--- v7/src/edwin/image.scm | 108 +++++++------- v7/src/edwin/keymap.scm | 206 ++++++++++++++++++++++----- v7/src/edwin/loadef.scm | 7 +- v7/src/edwin/modefs.scm | 7 +- v7/src/edwin/motion.scm | 65 ++++----- v7/src/edwin/struct.scm | 90 +++++++----- v7/src/edwin/utils.scm | 22 ++- v7/src/edwin/utlwin.scm | 148 ++++++++++--------- v7/src/edwin/window.scm | 41 +++--- v7/src/runtime/rgxcmp.scm | 95 +++++++------ 20 files changed, 1046 insertions(+), 689 deletions(-) diff --git a/v7/src/edwin/bufwfs.scm b/v7/src/edwin/bufwfs.scm index 3563a04ca..694863d1e 100644 --- a/v7/src/edwin/bufwfs.scm +++ b/v7/src/edwin/bufwfs.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -61,12 +61,12 @@ (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) @@ -74,10 +74,11 @@ (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)))))))))))) @@ -87,10 +88,10 @@ ;; 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) @@ -106,15 +107,15 @@ ;; 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))) @@ -127,22 +128,24 @@ (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) @@ -150,7 +153,7 @@ (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))) @@ -158,8 +161,8 @@ 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 @@ -168,7 +171,10 @@ (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) @@ -186,7 +192,7 @@ ;; 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) @@ -207,9 +213,9 @@ (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 diff --git a/v7/src/edwin/bufwin.scm b/v7/src/edwin/bufwin.scm index a4934c17f..62cc6a0e8 100644 --- a/v7/src/edwin/bufwin.scm +++ b/v7/src/edwin/bufwin.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -154,10 +154,10 @@ (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))) @@ -201,8 +201,8 @@ (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) @@ -227,9 +227,9 @@ (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)) @@ -260,7 +260,7 @@ (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)))) ;;;; Override Message @@ -315,7 +315,7 @@ (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 () @@ -325,9 +325,9 @@ (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)))) @@ -352,7 +352,7 @@ (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))) @@ -361,9 +361,9 @@ (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))) @@ -372,8 +372,8 @@ (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))))) @@ -386,21 +386,23 @@ (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) @@ -420,8 +422,8 @@ (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 @@ -447,24 +449,30 @@ (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) @@ -482,8 +490,9 @@ (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)) @@ -496,7 +505,8 @@ (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 @@ -513,9 +523,9 @@ (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) @@ -531,10 +541,10 @@ (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!))) @@ -557,12 +567,12 @@ (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!))) @@ -573,12 +583,13 @@ (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!))) @@ -606,9 +617,9 @@ (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 diff --git a/v7/src/edwin/bufwiu.scm b/v7/src/edwin/bufwiu.scm index ebae759cf..18ddf231f 100644 --- a/v7/src/edwin/bufwiu.scm +++ b/v7/src/edwin/bufwiu.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -61,13 +61,13 @@ (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 @@ -85,12 +85,12 @@ (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 @@ -111,19 +111,7 @@ (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)) @@ -132,24 +120,25 @@ (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) @@ -159,13 +148,13 @@ (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 @@ -174,7 +163,21 @@ (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)))))) (define (recompute-image!:top-changed window) (with-instance-variables buffer-window window () @@ -217,7 +220,7 @@ (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 @@ -229,11 +232,11 @@ (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*)) @@ -241,7 +244,7 @@ (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!))))) @@ -261,14 +264,14 @@ (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... ;;; ...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. @@ -284,7 +287,7 @@ (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. @@ -299,11 +302,14 @@ 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)) @@ -344,11 +350,11 @@ (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)))) @@ -356,11 +362,11 @@ (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)))) @@ -368,20 +374,20 @@ (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) @@ -389,10 +395,10 @@ (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) @@ -401,21 +407,21 @@ (%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 diff --git a/v7/src/edwin/bufwmc.scm b/v7/src/edwin/bufwmc.scm index 946b0bfbe..6ca54950b 100644 --- a/v7/src/edwin/bufwmc.scm +++ b/v7/src/edwin/bufwmc.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -79,21 +79,22 @@ (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 @@ -104,16 +105,16 @@ 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))) @@ -128,19 +129,19 @@ (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))))))) @@ -151,19 +152,20 @@ (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) diff --git a/v7/src/edwin/calias.scm b/v7/src/edwin/calias.scm index f2b6826d7..9f2f97455 100644 --- a/v7/src/edwin/calias.scm +++ b/v7/src/edwin/calias.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -97,6 +97,73 @@ (define-integrable (ascii-controlified? char) (< (char-code char) #x20)) + +(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 (xcharlist x)) (y (xchar->list y))) + (or (charname (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 diff --git a/v7/src/edwin/comtab.scm b/v7/src/edwin/comtab.scm index 7518074b3..ac691c139 100644 --- a/v7/src/edwin/comtab.scm +++ b/v7/src/edwin/comtab.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -203,4 +203,15 @@ ;; 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 diff --git a/v7/src/edwin/decls.scm b/v7/src/edwin/decls.scm index 1610ee5b2..7bf904e20 100644 --- a/v7/src/edwin/decls.scm +++ b/v7/src/edwin/decls.scm @@ -1,114 +1,182 @@ -(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)) + +(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 diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 3039d077c..a97b0ca32 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -163,6 +163,7 @@ MIT in each case. |# (files "comtab") (parent (edwin)) (export (edwin) + comtab->alist comtab-entry comtab-dispatch-alists comtab-key-bindings diff --git a/v7/src/edwin/grpops.scm b/v7/src/edwin/grpops.scm index e7f9b2ef3..8804cc1e0 100644 --- a/v7/src/edwin/grpops.scm +++ b/v7/src/edwin/grpops.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -64,24 +64,26 @@ (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 @@ -94,8 +96,8 @@ (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*))) @@ -111,50 +113,53 @@ (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*)))) (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) @@ -167,8 +172,8 @@ (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)))))) @@ -181,74 +186,75 @@ (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 diff --git a/v7/src/edwin/hlpcom.scm b/v7/src/edwin/hlpcom.scm index 7f8e9f78a..b62f6c3d6 100644 --- a/v7/src/edwin/hlpcom.scm +++ b/v7/src/edwin/hlpcom.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -49,7 +49,7 @@ (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) @@ -62,20 +62,21 @@ It reads another character (a subcommand) and dispatches on it." (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) @@ -84,7 +85,8 @@ W where-is. Type a command name and get its key binding." (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) diff --git a/v7/src/edwin/image.scm b/v7/src/edwin/image.scm index 2145a89a4..30d202c16 100644 --- a/v7/src/edwin/image.scm +++ b/v7/src/edwin/image.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -106,18 +106,18 @@ (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) (define (image-representation image) @@ -134,13 +134,15 @@ ((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))) @@ -151,19 +153,19 @@ (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)))))) @@ -173,16 +175,16 @@ (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)))))) @@ -195,7 +197,7 @@ (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 @@ -207,22 +209,25 @@ (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))))))))) + (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)) @@ -230,10 +235,12 @@ (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 @@ -241,28 +248,30 @@ (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)))))))) ;;;; Parsing @@ -272,14 +281,15 @@ (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))))))))) diff --git a/v7/src/edwin/keymap.scm b/v7/src/edwin/keymap.scm index a5432c218..47b6e88a8 100644 --- a/v7/src/edwin/keymap.scm +++ b/v7/src/edwin/keymap.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -46,50 +46,178 @@ (declare (usual-integrations)) +(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))))))))))) + (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*)))))))) + +(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 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)))) @@ -118,20 +118,20 @@ ;;; 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))))) @@ -187,13 +187,13 @@ (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)))))) ;;;; Motion by Columns @@ -214,36 +214,37 @@ (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 diff --git a/v7/src/edwin/struct.scm b/v7/src/edwin/struct.scm index 04cc1e374..aa3ac6dea 100644 --- a/v7/src/edwin/struct.scm +++ b/v7/src/edwin/struct.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -129,7 +129,7 @@ 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))) @@ -138,10 +138,10 @@ (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) @@ -159,17 +159,17 @@ (%make-region (group-start-mark group) (group-end-mark group))) (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)))) @@ -289,9 +289,18 @@ (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))))) + (define-integrable (mark~ mark1 mark2) (eq? (mark-group mark1) (mark-group mark2))) @@ -302,29 +311,29 @@ ;;; 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))) @@ -332,18 +341,18 @@ (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))))) (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)) @@ -355,7 +364,7 @@ (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)))) @@ -499,7 +508,7 @@ ((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) @@ -513,7 +522,7 @@ ((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))))))) @@ -531,7 +540,7 @@ (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)))))))) @@ -543,7 +552,7 @@ ((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)))))))) @@ -603,9 +612,16 @@ (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))) diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm index 4e76e7d4f..b8208463d 100644 --- a/v7/src/edwin/utils.scm +++ b/v7/src/edwin/utils.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -77,21 +77,19 @@ (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) diff --git a/v7/src/edwin/utlwin.scm b/v7/src/edwin/utlwin.scm index 54643c885..eb09e4b46 100644 --- a/v7/src/edwin/utlwin.scm +++ b/v7/src/edwin/utlwin.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -61,55 +61,63 @@ (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) @@ -160,7 +168,7 @@ (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)))))) @@ -170,60 +178,60 @@ (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)))) (define (string-base:direct-output-insert-char! window x char) (with-instance-variables string-base window (x char) @@ -234,7 +242,7 @@ (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 () @@ -253,9 +261,10 @@ (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 () @@ -270,33 +279,33 @@ (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))))))) @@ -309,8 +318,8 @@ 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 @@ -328,7 +337,7 @@ (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) @@ -338,16 +347,16 @@ (: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) ;;;; Cursor Window @@ -377,7 +386,8 @@ (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) diff --git a/v7/src/edwin/window.scm b/v7/src/edwin/window.scm index 380e288b5..0f891c1df 100644 --- a/v7/src/edwin/window.scm +++ b/v7/src/edwin/window.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -223,25 +223,25 @@ 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) @@ -375,12 +375,12 @@ (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)))))))))) @@ -409,10 +409,10 @@ (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)) @@ -428,10 +428,11 @@ (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))) diff --git a/v7/src/runtime/rgxcmp.scm b/v7/src/runtime/rgxcmp.scm index 1496201f4..53838d434 100644 --- a/v7/src/runtime/rgxcmp.scm +++ b/v7/src/runtime/rgxcmp.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -155,31 +155,35 @@ (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))))))))))) ;;;; Char-Set Compiler @@ -204,18 +208,18 @@ (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) @@ -350,7 +354,7 @@ (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) @@ -391,12 +395,14 @@ (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))))) @@ -406,7 +412,7 @@ (null? stack)) (define-integrable (stack-full?) - (>= (stack-length) stack-maximum-length)) + (not (fix:< (stack-length) stack-maximum-length))) (define-integrable (stack-length) (length stack)) @@ -444,7 +450,7 @@ (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) @@ -560,20 +566,20 @@ ;; 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) @@ -608,11 +614,11 @@ (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)) @@ -620,16 +626,16 @@ ;; 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)) @@ -642,7 +648,7 @@ (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))) @@ -652,7 +658,7 @@ 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)) @@ -667,7 +673,7 @@ (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))))))) @@ -676,7 +682,7 @@ (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)) @@ -692,17 +698,18 @@ (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)) ;;;; Compiled Pattern Disassembler -- 2.25.1