;;; -*-Scheme-*-
;;;
-;;; $Id: buffrm.scm,v 1.49 1994/03/08 20:24:23 cph Exp $
+;;; $Id: buffrm.scm,v 1.50 1994/09/08 20:34:04 adams Exp $
;;;
;;; Copyright (c) 1986, 1989-94 Massachusetts Institute of Technology
;;;
(define-integrable (window-home-cursor! window)
(buffer-window/home-cursor! (frame-text-inferior window)))
+(define-integrable (window-char->image frame char)
+ (%window-char->image (frame-text-inferior frame) char))
+
(define-integrable (window-direct-output-forward-char! frame)
(buffer-window/direct-output-forward-char! (frame-text-inferior frame)))
8
exact-nonnegative-integer?)
+(define-variable-per-buffer char-image-strings
+ "A vector of 256 strings mapping ascii bytes to image strings.
+Each image is a short string of at least one character.
+Index 0 might contain \"^@\" so ascii NUL appears as ^@.
+The indices for normal printing characters usually contain a
+string containing just that character, e.g. index 65 usually contains \"A\".
+Automatically becomes local when set in any fashion."
+ default-char-image-strings
+ (lambda (object)
+ (and (vector? object)
+ (= (vector-length object) 256)
+ (let loop ((i 0))
+ (if (= i 256)
+ #T
+ (and (string? (vector-ref object i))
+ (<= 1 (string-length (vector-ref object i)) 255)
+ (loop (+ i 1))))))))
+
(let ((setup-truncate-lines!
(lambda (buffer variable)
variable ;ignore
- (for-each window-redraw!
- (if buffer
- (buffer-windows buffer)
- (window-list))))))
+ (for-each window-redraw! ;window-redraw! recaches these variables
+ (if buffer
+ (buffer-windows buffer)
+ (window-list))))))
(add-variable-assignment-daemon!
(ref-variable-object truncate-lines)
setup-truncate-lines!)
setup-truncate-lines!)
(add-variable-assignment-daemon!
(ref-variable-object tab-width)
+ setup-truncate-lines!)
+ (add-variable-assignment-daemon!
+ (ref-variable-object char-image-strings)
setup-truncate-lines!))
\f
;;;; Window Configurations
;;; -*-Scheme-*-
;;;
-;;; $Id: bufwfs.scm,v 1.18 1993/10/05 23:05:51 cph Exp $
+;;; $Id: bufwfs.scm,v 1.19 1994/09/08 20:34:04 adams Exp $
;;;
;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
(define (fill-top window start)
(let ((group (%window-group window))
(start-column 0)
+ (char-image-strings (%window-char-image-strings window))
(tab-width (%window-tab-width window))
(truncate-lines? (%window-truncate-lines? window))
(x-size (window-x-size window)))
(start-index (%window-line-start-index window end-index))
(end-column
(group-columns group start-index end-index
- start-column tab-width))
+ start-column tab-width
+ char-image-strings))
(y-size (column->y-size end-column x-size truncate-lines?))
(y (fix:- y y-size)))
(draw-region! window
(define (fill-middle window top-end bot-start)
(let ((group (%window-group window))
(start-column 0)
+ (char-image-strings (%window-char-image-strings window))
(tab-width (%window-tab-width window))
(truncate-lines? (%window-truncate-lines? window))
(x-size (window-x-size window))
(if (fix:< start-index bot-start-index)
(let ((index&column
(group-line-columns group start-index bot-start-index
- start-column tab-width)))
+ start-column tab-width
+ char-image-strings)))
(let ((end-index (car index&column))
(end-column (cdr index&column)))
(let ((y-size
(define (fill-bottom window end)
(let ((group (%window-group window))
(start-column 0)
+ (char-image-strings (%window-char-image-strings window))
(tab-width (%window-tab-width window))
(truncate-lines? (%window-truncate-lines? window))
(x-size (window-x-size window))
(let ((start-index (fix:+ index 1)))
(let ((index&column
(group-line-columns group start-index group-end
- start-column tab-width)))
+ start-column tab-width
+ char-image-strings)))
(let ((end-index (car index&column))
(end-column (cdr index&column)))
(let ((y-size
(define (generate-outlines window start end)
(let ((group (%window-group window))
(start-column 0)
+ (char-image-strings (%window-char-image-strings window))
(tab-width (%window-tab-width window))
(truncate-lines? (%window-truncate-lines? window))
(x-size (window-x-size window))
(let loop ((outline false) (start-index (o3-index start)) (y (o3-y start)))
(let ((index&column
(group-line-columns group start-index group-end
- start-column tab-width)))
+ start-column tab-width char-image-strings)))
(let ((end-index (car index&column))
(end-column (cdr index&column)))
(let ((line-y (column->y-size end-column x-size truncate-lines?)))
(xu (fix:+ (%window-saved-x-start window)
(%window-saved-xu window)))
(y-start (fix:+ (%window-saved-y-start window) y))
+ (char-image-strings (%window-char-image-strings window))
(truncate-lines? (%window-truncate-lines? window))
(tab-width (%window-tab-width window))
(results substring-image-results))
(lambda (index xl*)
(group-image! group index end-index*
line xl* xm
- tab-width column-offset results)
+ tab-width column-offset results
+ char-image-strings)
(cond ((fix:= (vector-ref results 0) end-index)
(let ((xl* (vector-ref results 1)))
(let ((line
(partial-image! (group-right-char group index)
partial
line xl* xm
- tab-width)
+ tab-width
+ char-image-strings)
(if (fix:> partial columns)
(begin
(string-set! line xm #\\)
;;; -*-Scheme-*-
;;;
-;;; $Id: bufwin.scm,v 1.302 1994/09/08 01:28:47 cph Exp $
+;;; $Id: bufwin.scm,v 1.303 1994/09/08 20:34:04 adams Exp $
;;;
;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
;; for redisplay.
truncate-lines?
tab-width
+ char-image-strings
;; The point marker in this window.
point
(with-instance-variables buffer-window window (tab-width*)
(set! tab-width tab-width*)))
+(define-integrable (%window-char-image-strings window)
+ (with-instance-variables buffer-window window () char-image-strings))
+
+(define-integrable (%set-window-char-image-strings! window char-image-strings*)
+ (with-instance-variables buffer-window window (char-image-strings*)
+ (set! char-image-strings char-image-strings*)))
+
+(define-integrable (%window-char->image window char)
+ (vector-ref (%window-char-image-strings window)
+ (char->ascii char)))
+
(define-integrable (%window-point window)
(with-instance-variables buffer-window window () point))
((%window-debug-trace window) 'window window 'force-redraw!))
(let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
(%set-window-force-redraw?! window true)
+ (%recache-window-buffer-local-variables! window)
(%clear-window-incremental-redisplay-state! window)
(window-needs-redisplay! window)
(set-interrupt-enables! mask)
(%set-window-override-string! window false)
(%set-window-clip-daemon! window (make-clip-daemon window))
(%set-window-debug-trace! window false)
- (%set-window-saved-screen! window false))
+ (%set-window-saved-screen! window false)
+ (%set-window-force-redraw?! window false))
(define (%release-window-outlines! window)
(%set-window-start-outline! window false)
(define (%recache-window-buffer-local-variables! window)
(let ((maybe-recache
- (lambda (read write value)
- (let ((value* (read window)))
- (if (not (eqv? value value*))
+ (lambda (read write new-value)
+ (let ((old-value (read window)))
+ (if (not (eqv? new-value old-value))
(begin
(%set-window-force-redraw?! window #t)
- (write window value))))))
+ (write window new-value))))))
(buffer (%window-buffer window)))
(maybe-recache
%window-truncate-lines?
(maybe-recache
%window-tab-width
%set-window-tab-width!
- (variable-local-value buffer (ref-variable-object tab-width)))))
+ (variable-local-value buffer (ref-variable-object tab-width)))
+ (maybe-recache
+ %window-char-image-strings
+ %set-window-char-image-strings!
+ (variable-local-value buffer (ref-variable-object char-image-strings)))))
\f
;;;; Buffer and Point
(if (%window-buffer window)
(%unset-window-buffer! window))
(%set-window-buffer! window new-buffer)
+ (%recache-window-buffer-local-variables! window)
(let ((group (%window-group window)))
(add-group-clip-daemon! group (%window-clip-daemon window))
(%set-window-point-index! window (mark-index (group-point group))))
false)))
(substring-image! string 0 end
line xl (fix:- xu 1)
- false 0 results)
+ false 0 results
+ (%window-char-image-strings window))
(if (fix:= (vector-ref results 0) end)
(do ((x (vector-ref results 1) (fix:+ x 1)))
((fix:= x xu))
;;; -*-Scheme-*-
;;;
-;;; $Id: bufwiu.scm,v 1.28 1994/09/08 01:28:53 cph Exp $
+;;; $Id: bufwiu.scm,v 1.29 1994/09/08 20:34:04 adams Exp $
;;;
;;; Copyright (c) 1986, 1989-94 Massachusetts Institute of Technology
;;;
;;;; Update
(define (update-outlines! window)
- (%guarantee-start-mark! window)
;; This procedure sets FORCE-REDRAW? if any cached variable has changed.
(%recache-window-buffer-local-variables! window)
+ (%guarantee-start-mark! window)
(if (%window-force-redraw? window)
(begin
(%set-window-force-redraw?! window false)
;;; -*-Scheme-*-
;;;
-;;; $Id: bufwmc.scm,v 1.16 1993/01/12 10:50:39 cph Exp $
+;;; $Id: bufwmc.scm,v 1.17 1994/09/08 20:34:04 adams Exp $
;;;
;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
(define (buffer-window/index->x window index)
(let ((start (%window-line-start-index window index))
(group (%window-group window))
+ (char-image-strings (%window-char-image-strings window))
(tab-width (%window-tab-width window)))
- (column->x (group-columns group start index 0 tab-width)
+ (column->x (group-columns group start index 0 tab-width char-image-strings)
(window-x-size window)
(%window-truncate-lines? window)
(%window-line-end-index? window index))))
(with-values (lambda () (start-point-for-index window index))
(lambda (start-index start-y line-start-index)
(let ((group (%window-group window))
+ (char-image-strings (%window-char-image-strings window))
(tab-width (%window-tab-width window)))
(let ((xy
(column->coordinates
- (group-columns group line-start-index index 0 tab-width)
+ (group-columns group line-start-index index 0 tab-width
+ char-image-strings)
(window-x-size window)
(%window-truncate-lines? window)
(%window-line-end-index? window index))))
(if (fix:= index start)
y
(let ((group (%window-group window))
+ (char-image-strings (%window-char-image-strings window))
(tab-width (%window-tab-width window))
(x-size (window-x-size window))
(truncate-lines? (%window-truncate-lines? window)))
(start
(or (%find-previous-newline group end group-start)
group-start))
- (columns (group-columns group start end 0 tab-width))
+ (columns (group-columns group start end 0 tab-width
+ char-image-strings))
(y
(fix:- y
(column->y-size columns
(loop start y)
(fix:+ y
(column->y (group-columns group start index
- 0 tab-width)
+ 0 tab-width
+ char-image-strings)
x-size
truncate-lines?
(%window-line-end-index? window
(let ((group-end (%window-group-end-index window)))
(let loop ((start start) (y y))
(let ((e&c
- (group-line-columns group start group-end 0 tab-width)))
+ (group-line-columns group start group-end 0 tab-width
+ char-image-strings)))
(if (fix:> index (car e&c))
(loop (fix:+ (car e&c) 1)
(fix:+ y
truncate-lines?)))
(fix:+ y
(column->y (group-columns group start index
- 0 tab-width)
+ 0 tab-width
+ char-image-strings)
x-size
truncate-lines?
(%window-line-end-index?
(fix:< y yu)
y)
(let ((group (%window-group window))
+ (char-image-strings (%window-char-image-strings window))
(tab-width (%window-tab-width window))
(x-size (window-x-size window))
(truncate-lines? (%window-truncate-lines? window)))
(or (%find-previous-newline group end group-start)
group-start))
(columns
- (group-columns group start end 0 tab-width))
+ (group-columns group start end 0 tab-width
+ char-image-strings))
(y
(fix:- y
(column->y-size columns
start
index
0
- tab-width)
+ tab-width
+ char-image-strings)
x-size
truncate-lines?
(%window-line-end-index?
(and (fix:< y yu)
(let ((e&c
(group-line-columns group start group-end 0
- tab-width)))
+ tab-width char-image-strings)))
(if (fix:> index (car e&c))
(loop (fix:+ (car e&c) 1)
(fix:+ y
start
index
0
- tab-width)
+ tab-width
+ char-image-strings)
x-size
truncate-lines?
(%window-line-end-index?
(let ((x-size (window-x-size window))
(y-size (window-y-size window))
(group (%window-group window))
+ (char-image-strings (%window-char-image-strings window))
(tab-width (%window-tab-width window))
(truncate-lines? (%window-truncate-lines? window))
(group-end (%window-group-end-index window)))
(let loop ((start start) (y y))
(and (fix:< y y-size)
(let ((e&c
- (group-line-columns group start group-end 0 tab-width)))
+ (group-line-columns group start group-end 0 tab-width
+ char-image-strings)))
(if (fix:> index (car e&c))
(loop (fix:+ (car e&c) 1)
(fix:+ y
start
index
0
- tab-width)
+ tab-width
+ char-image-strings)
x-size
truncate-lines?
(%window-line-end-index?
(define (predict-index window start y-start x y)
;; Assumes that START is a line start.
(let ((group (%window-group window))
+ (char-image-strings (%window-char-image-strings window))
(tab-width (%window-tab-width window))
(x-size (window-x-size window))
(truncate-lines? (%window-truncate-lines? window)))
(start
(or (%find-previous-newline group end group-start)
group-start))
- (columns (group-columns group start end 0 tab-width))
+ (columns (group-columns group start end 0 tab-width
+ char-image-strings))
(y-start
(fix:- y-start
(column->y-size columns
(if (fix:< column columns)
column
columns))
- tab-width)
+ tab-width
+ char-image-strings)
0))))))
(let ((group-end (%window-group-end-index window)))
(let loop ((start start) (y-start y-start))
- (let ((e&c (group-line-columns group start group-end 0 tab-width)))
+ (let ((e&c (group-line-columns group start group-end 0 tab-width
+ char-image-strings)))
(let ((y-end
(fix:+ y-start
(column->y-size (cdr e&c)
(if (fix:< column (cdr e&c))
column
(cdr e&c)))
- tab-width)
+ tab-width
+ char-image-strings)
0)))))))))
\f
(define (compute-window-start window index y-index)
\f
(define (compute-window-start-ntl window index y-index)
(let ((group (%window-group window))
+ (char-image-strings (%window-char-image-strings window))
(tab-width (%window-tab-width window))
(x-size (window-x-size window)))
(let ((group-start (group-display-start-index group))
group-start))))
(let ((y-start
(fix:- y-index
- (column->y (group-columns group start index 0 tab-width)
+ (column->y (group-columns group start index 0 tab-width
+ char-image-strings)
x-size
#f
(%window-line-end-index? window index)))))
(let* ((column (fix:* (fix:- 0 y-start) x-max))
(icp
(group-column->index group start group-end
- 0 column tab-width)))
+ 0 column tab-width
+ char-image-strings)))
(cond ((fix:= (vector-ref icp 1) column)
(vector start
y-start
(fix:-
y-start
(column->y-size (group-columns group start end
- 0 tab-width)
+ 0 tab-width
+ char-image-strings)
x-size
#f))))
(cond ((fix:= y-start 0)
(group-column->index
group start end
0 (fix:* (fix:- 0 y-start) x-max)
- tab-width)))
+ tab-width char-image-strings)))
(vector start
y-start
(vector-ref icp 0)
;;; -*-Scheme-*-
;;;
-;;; $Id: comred.scm,v 1.110 1993/12/17 00:09:21 cph Exp $
+;;; $Id: comred.scm,v 1.111 1994/09/08 20:34:04 adams Exp $
;;;
;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
(define (%dispatch-on-command window command record?)
(set! *command* command)
(guarantee-command-loaded command)
+ (define (char-image-string ch)
+ (window-char->image window ch))
(let ((point (window-point window))
(point-x (window-point-x window))
(procedure (command-procedure command)))
(and (buffer-auto-save-modified? buffer)
(null? (cdr (buffer-windows buffer)))))
(line-end? point)
- (char-graphic? key)
+ (not (char=? key #\newline))
+ (not (char=? key #\tab))
+ (let ((image (char-image-string key)))
+ (and (fix:= (string-length image) 1)
+ (char=? (string-ref image 0) key)))
(fix:< point-x (fix:- (window-x-size window) 1)))
(window-direct-output-insert-char! window key)
(region-insert-char! point key))))
((eq? command (ref-command-object forward-char))
(if (and (not (window-needs-redisplay? window))
(not (group-end? point))
- (char-graphic? (mark-right-char point))
+ (let ((char (mark-right-char point)))
+ (and (not (char=? char #\newline))
+ (not (char=? char #\tab))
+ (fix:= (string-length (char-image-string char))
+ 1)))
(fix:< point-x (fix:- (window-x-size window) 2)))
(window-direct-output-forward-char! window)
(normal)))
((eq? command (ref-command-object backward-char))
(if (and (not (window-needs-redisplay? window))
(not (group-start? point))
- (char-graphic? (mark-left-char point))
+ (let ((char (mark-left-char point)))
+ (and (not (char=? char #\newline))
+ (not (char=? char #\tab))
+ (fix:= (string-length (char-image-string char))
+ 1)))
(fix:< 0 point-x)
(fix:< point-x (fix:- (window-x-size window) 1)))
(window-direct-output-backward-char! window)
;;; -*-Scheme-*-
;;;
-;;; $Id: image.scm,v 1.131 1993/10/16 12:17:49 cph Exp $
+;;; $Id: image.scm,v 1.132 1994/09/08 20:34:04 adams Exp $
;;;
;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define (group-columns group start end column tab-width)
- (let ((text (group-text group))
- (gap-start (group-gap-start group))
- (gap-end (group-gap-end group))
+(define (group-columns group start end column tab-width char-image-strings)
+ (let ((text (group-text group))
+ (gap-start (group-gap-start group))
+ (gap-end (group-gap-end group))
(gap-length (group-gap-length group)))
(cond ((fix:<= end gap-start)
- (substring-columns text start end column tab-width))
+ (substring-columns text start end column tab-width char-image-strings))
((fix:<= gap-start start)
(substring-columns text
(fix:+ start gap-length)
(fix:+ end gap-length)
column
- tab-width))
+ tab-width
+ char-image-strings))
(else
(substring-columns text
gap-end
(fix:+ end gap-length)
(substring-columns text start gap-start
- column tab-width)
- tab-width)))))
+ column tab-width
+ char-image-strings)
+ tab-width
+ char-image-strings)))))
-(define (string-columns string column tab-width)
- (substring-columns string 0 (string-length string) column tab-width))
+(define (string-columns string column tab-width char-image-strings)
+ (substring-columns string 0 (string-length string) column tab-width
+ char-image-strings))
-(define (substring-columns string start end column tab-width)
+(define (substring-columns string start end column tab-width
+ char-image-strings)
(if tab-width
(do ((index start (fix:+ index 1))
(column column
(if (fix:= ascii (char->integer #\tab))
(fix:- tab-width
(fix:remainder column tab-width))
- (vector-ref char-image-lengths ascii))))))
+ (string-length
+ (vector-ref char-image-strings ascii)))))))
((fix:= index end) column))
(do ((index start (fix:+ index 1))
(column column
(fix:+ column
- (vector-ref char-image-lengths
- (vector-8b-ref string index)))))
+ (string-length
+ (vector-ref char-image-strings
+ (vector-8b-ref string index))))))
((fix:= index end) column))))
-(define-integrable char-image-lengths
- '#(2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2
- 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4
- 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4
- 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4
- 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4))
+;;(define-integrable char-image-lengths
+;; '#(2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
+;; 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+;; 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+;; 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2
+;; 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4
+;; 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4
+;; 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4
+;; 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4))
+
+(define default-char-image-strings
+ '#("^@" "^A" "^B" "^C" "^D" "^E" "^F" "^G"
+ "^H" "^I" "^J" "^K" "^L" "^M" "^N" "^O"
+ "^P" "^Q" "^R" "^S" "^T" "^U" "^V" "^W"
+ "^X" "^Y" "^Z" "^[" "^\\" "^]" "^^" "^_"
+ " " "!" "\"" "#" "$" "%" "&" "'" "(" ")" "*" "+" "," "-" "." "/"
+ "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" ":" ";" "<" "=" ">" "?"
+ "@" "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O"
+ "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z" "[" "\\" "]" "^" "_"
+ "`" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o"
+ "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" "{" "|" "}" "~" "^?"
+ "\\200" "\\201" "\\202" "\\203" "\\204" "\\205" "\\206" "\\207"
+ "\\210" "\\211" "\\212" "\\213" "\\214" "\\215" "\\216" "\\217"
+ "\\220" "\\221" "\\222" "\\223" "\\224" "\\225" "\\226" "\\227"
+ "\\230" "\\231" "\\232" "\\233" "\\234" "\\235" "\\236" "\\237"
+ "\\240" "\\241" "\\242" "\\243" "\\244" "\\245" "\\246" "\\247"
+ "\\250" "\\251" "\\252" "\\253" "\\254" "\\255" "\\256" "\\257"
+ "\\260" "\\261" "\\262" "\\263" "\\264" "\\265" "\\266" "\\267"
+ "\\270" "\\271" "\\272" "\\273" "\\274" "\\275" "\\276" "\\277"
+ "\\300" "\\301" "\\302" "\\303" "\\304" "\\305" "\\306" "\\307"
+ "\\310" "\\311" "\\312" "\\313" "\\314" "\\315" "\\316" "\\317"
+ "\\320" "\\321" "\\322" "\\323" "\\324" "\\325" "\\326" "\\327"
+ "\\330" "\\331" "\\332" "\\333" "\\334" "\\335" "\\336" "\\337"
+ "\\340" "\\341" "\\342" "\\343" "\\344" "\\345" "\\346" "\\347"
+ "\\350" "\\351" "\\352" "\\353" "\\354" "\\355" "\\356" "\\357"
+ "\\360" "\\361" "\\362" "\\363" "\\364" "\\365" "\\366" "\\367"
+ "\\370" "\\371" "\\372" "\\373" "\\374" "\\375" "\\376" "\\377"))
+
+(define default-char-image-strings/ascii
+ '#("[NUL]" "[SOH]" "[STX]" "[ETX]" "[EOT]" "[ENQ]" "[ACK]" "[BEL]"
+ "[BS]" "[HT]" "[NL]" "[VT]" "[Page]" "[CR]" "[SO]" "[SI]"
+ "[DLE]" "[DC1]" "[DC2]" "[DC3]" "[DC4]" "[NAK]" "[SYN]" "[ETB]"
+ "[CAN]" "[EM]" "[SUB]" "[ESC]" "[FS]" "[GS]" "[RS]" "[US]"
+ " " "!" "\"" "#" "$" "%" "&" "'" "(" ")" "*" "+" "," "-" "." "/"
+ "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" ":" ";" "<" "=" ">" "?"
+ "@" "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O"
+ "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z" "[" "\\" "]" "^" "_"
+ "`" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o"
+ "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" "{" "|" "}" "~" "^?"
+ "\\200" "\\201" "\\202" "\\203" "\\204" "\\205" "\\206" "\\207"
+ "\\210" "\\211" "\\212" "\\213" "\\214" "\\215" "\\216" "\\217"
+ "\\220" "\\221" "\\222" "\\223" "\\224" "\\225" "\\226" "\\227"
+ "\\230" "\\231" "\\232" "\\233" "\\234" "\\235" "\\236" "\\237"
+ "\\240" "\\241" "\\242" "\\243" "\\244" "\\245" "\\246" "\\247"
+ "\\250" "\\251" "\\252" "\\253" "\\254" "\\255" "\\256" "\\257"
+ "\\260" "\\261" "\\262" "\\263" "\\264" "\\265" "\\266" "\\267"
+ "\\270" "\\271" "\\272" "\\273" "\\274" "\\275" "\\276" "\\277"
+ "\\300" "\\301" "\\302" "\\303" "\\304" "\\305" "\\306" "\\307"
+ "\\310" "\\311" "\\312" "\\313" "\\314" "\\315" "\\316" "\\317"
+ "\\320" "\\321" "\\322" "\\323" "\\324" "\\325" "\\326" "\\327"
+ "\\330" "\\331" "\\332" "\\333" "\\334" "\\335" "\\336" "\\337"
+ "\\340" "\\341" "\\342" "\\343" "\\344" "\\345" "\\346" "\\347"
+ "\\350" "\\351" "\\352" "\\353" "\\354" "\\355" "\\356" "\\357"
+ "\\360" "\\361" "\\362" "\\363" "\\364" "\\365" "\\366" "\\367"
+ "\\370" "\\371" "\\372" "\\373" "\\374" "\\375" "\\376" "\\377"))
+
\f
-(define (group-line-columns group start end column tab-width)
+(define (group-line-columns group start end column tab-width char-image-strings)
;; Like GROUP-COLUMNS, but stops at line end.
- (let ((text (group-text group))
- (gap-start (group-gap-start group))
- (gap-end (group-gap-end group))
+ (let ((text (group-text group))
+ (gap-start (group-gap-start group))
+ (gap-end (group-gap-end group))
(gap-length (group-gap-length group)))
(cond ((fix:<= end gap-start)
- (substring-line-columns text start end column tab-width))
+ (substring-line-columns text start end column tab-width char-image-strings))
((fix:<= gap-start start)
(let ((i&c
(substring-line-columns text
(fix:+ start gap-length)
(fix:+ end gap-length)
column
- tab-width)))
+ tab-width
+ char-image-strings)))
(cons (fix:- (car i&c) gap-length) (cdr i&c))))
(else
(let ((i&c
(substring-line-columns text start gap-start
- column tab-width)))
+ column tab-width
+ char-image-strings)))
(if (fix:< (car i&c) gap-start)
i&c
(let ((i&c
gap-end
(fix:+ end gap-length)
(cdr i&c)
- tab-width)))
+ tab-width
+ char-image-strings)))
(cons (fix:- (car i&c) gap-length) (cdr i&c)))))))))
-(define (string-line-columns string column tab-width)
- (substring-line-columns string 0 (string-length string) column tab-width))
+(define (string-line-columns string column tab-width char-image-strings)
+ (substring-line-columns string 0 (string-length string) column tab-width
+ char-image-strings))
-(define (substring-line-columns string start end column tab-width)
+(define (substring-line-columns string start end column tab-width
+ char-image-strings)
(if tab-width
(let loop ((index start) (column column))
(if (fix:= index end)
(if (fix:= ascii (char->integer #\tab))
(fix:- tab-width
(fix:remainder column tab-width))
- (vector-ref char-image-lengths ascii))))))))
+ (string-length
+ (vector-ref char-image-strings ascii)))))))))
(let loop ((index start) (column column))
(if (fix:= index end)
(cons index column)
(cons index column)
(loop (fix:+ index 1)
(fix:+ column
- (vector-ref char-image-lengths ascii)))))))))
+ (string-length
+ (vector-ref char-image-strings ascii))))))))))
\f
-(define (group-column->index group start end start-column column tab-width)
- (let ((text (group-text group))
- (gap-start (group-gap-start group))
- (gap-end (group-gap-end group))
+(define (group-column->index group start end start-column column tab-width
+ char-image-strings)
+ (let ((text (group-text group))
+ (gap-start (group-gap-start group))
+ (gap-end (group-gap-end group))
(gap-length (group-gap-length group)))
(cond ((fix:<= end gap-start)
(substring-column->index text start end start-column column
- tab-width))
+ tab-width char-image-strings))
((fix:<= gap-start start)
(let ((result
(substring-column->index text
(fix:+ end gap-length)
start-column
column
- tab-width)))
+ tab-width
+ char-image-strings)))
(vector-set! result 0 (fix:- (vector-ref result 0) gap-length))
result))
(else
(let ((result
(substring-column->index text start gap-start
- start-column column tab-width)))
+ start-column column tab-width
+ char-image-strings)))
(if (and (fix:< (vector-ref result 1) column)
(fix:= (vector-ref result 0) gap-start))
(let ((result
(fix:+ (vector-ref result 1)
(vector-ref result 2))
column
- tab-width)))
+ tab-width
+ char-image-strings)))
(vector-set! result 0
(fix:- (vector-ref result 0) gap-length))
result)
result))))))
(define (substring-column->index string start end start-column column
- tab-width)
+ tab-width char-image-strings)
;; If COLUMN falls in the middle of a multi-column character, the
;; index returned is that of the character. Thinking of the index
;; as a pointer between characters, the value is the pointer to the
(let ((ascii (vector-8b-ref string index)))
(if (fix:= ascii (char->integer #\tab))
(fix:- tab-width (fix:remainder c tab-width))
- (vector-ref char-image-lengths ascii))))))
+ (string-length
+ (vector-ref char-image-strings ascii)))))))
(if (fix:> c column)
(vector index column (fix:- c column))
(loop (fix:+ index 1) c)))))
(vector index c 0)
(let ((c
(fix:+ c
- (vector-ref char-image-lengths
- (vector-8b-ref string index)))))
+ (string-length
+ (vector-ref char-image-strings
+ (vector-8b-ref string index))))))
(if (fix:> c column)
(vector index column (fix:- c column))
(loop (fix:+ index 1) c)))))))
\f
(define (substring-image! string string-start string-end
image image-start image-end
- tab-width column-offset results)
+ tab-width column-offset results
+ char-image-strings)
(let loop ((string-index string-start) (image-index image-start))
(if (or (fix:= image-index image-end)
(fix:= string-index string-end))
(vector-set! results 0 string-index)
(vector-set! results 1 image-end)
(vector-set! results 2 partial))))
- (cond ((fix:< ascii #o040)
- (if (and (fix:= ascii (char->integer #\tab)) tab-width)
- (let ((n
- (fix:- tab-width
- (fix:remainder (fix:+ column-offset
- image-index)
- tab-width))))
- (let ((end (fix:+ image-index n)))
- (if (fix:<= end image-end)
- (begin
- (do ((image-index image-index
- (fix:+ image-index 1)))
- ((fix:= image-index end))
- (string-set! image image-index #\space))
- (loop (fix:+ string-index 1) end))
- (begin
- (do ((image-index image-index
- (fix:+ image-index 1)))
- ((fix:= image-index image-end))
- (string-set! image image-index #\space))
- (partial (fix:- end image-end))))))
- (begin
- (string-set! image image-index #\^)
- (if (fix:= (fix:+ image-index 1) image-end)
- (partial 1)
- (begin
- (vector-8b-set! image
- (fix:+ image-index 1)
- (fix:+ ascii #o100))
- (loop (fix:+ string-index 1)
- (fix:+ image-index 2)))))))
- ((fix:< ascii #o177)
- (vector-8b-set! image image-index ascii)
- (loop (fix:+ string-index 1) (fix:+ image-index 1)))
- ((fix:= ascii #o177)
- (string-set! image image-index #\^)
- (if (fix:= (fix:+ image-index 1) image-end)
- (partial 1)
- (begin
- (string-set! image (fix:+ image-index 1) #\?)
- (loop (fix:+ string-index 1) (fix:+ image-index 2)))))
- (else
- (string-set! image image-index #\\)
- (let ((q (fix:quotient ascii 8)))
- (let ((d1 (fix:+ (fix:quotient q 8) (char->integer #\0)))
- (d2 (fix:+ (fix:remainder q 8) (char->integer #\0)))
- (d3
- (fix:+ (fix:remainder ascii 8) (char->integer #\0))))
- (cond ((fix:<= (fix:+ image-index 4) image-end)
- (vector-8b-set! image (fix:+ image-index 1) d1)
- (vector-8b-set! image (fix:+ image-index 2) d2)
- (vector-8b-set! image (fix:+ image-index 3) d3)
- (loop (fix:+ string-index 1)
- (fix:+ image-index 4)))
- ((fix:= (fix:+ image-index 1) image-end)
- (partial 3))
- ((fix:= (fix:+ image-index 2) image-end)
- (vector-8b-set! image (fix:+ image-index 1) d1)
- (partial 2))
- (else
- (vector-8b-set! image (fix:+ image-index 1) d1)
- (vector-8b-set! image (fix:+ image-index 2) d2)
- (partial 1)))))))))))
+ (if (and (fix:= ascii (char->integer #\tab)) tab-width)
+ (let ((n
+ (fix:- tab-width
+ (fix:remainder (fix:+ column-offset
+ image-index)
+ tab-width))))
+ (let ((end (fix:+ image-index n)))
+ (if (fix:<= end image-end)
+ (begin
+ (do ((image-index image-index
+ (fix:+ image-index 1)))
+ ((fix:= image-index end))
+ (string-set! image image-index #\space))
+ (loop (fix:+ string-index 1) end))
+ (begin
+ (do ((image-index image-index
+ (fix:+ image-index 1)))
+ ((fix:= image-index image-end))
+ (string-set! image image-index #\space))
+ (partial (fix:- end image-end))))))
+ (let* ((image-string (vector-ref char-image-strings ascii))
+ (image-len (string-length image-string)))
+ (string-set! image image-index (string-ref image-string 0))
+ (if (fix:= image-len 1)
+ (loop (fix:+ string-index 1) (fix:+ image-index 1))
+ (if (fix:< (fix:+ image-index image-len) image-end)
+ (let copy-image-loop ((i 1))
+ (string-set! image (fix:+ image-index i)
+ (string-ref image-string i))
+ (if (fix:= (fix:+ i 1) image-len)
+ (loop (fix:+ string-index 1)
+ (fix:+ image-index image-len))
+ (copy-image-loop (fix:+ i 1))))
+ (let copy-image-loop ((i 1))
+ (cond ((fix:= i image-len)
+ (loop (fix:+ string-index 1)
+ (fix:+ image-index image-len)))
+ ((fix:= (fix:+ image-index i) image-end)
+ (partial (fix:- image-len i)))
+ (else
+ (string-set! image (fix:+ image-index i)
+ (string-ref image-string i))
+ (copy-image-loop (fix:+ i 1)))))))))))))
\f
-(define (string-image string start-column tab-width)
- (substring-image string 0 (string-length string) start-column tab-width))
+(define (string-image string start-column tab-width char-image-strings)
+ (substring-image string 0 (string-length string) start-column tab-width
+ char-image-strings))
-(define (substring-image string start end start-column tab-width)
+(define (substring-image string start end start-column tab-width
+ char-image-strings)
(let ((columns
- (fix:- (substring-columns string start end start-column tab-width)
+ (fix:- (substring-columns string start end start-column tab-width
+ char-image-strings)
start-column)))
(let ((image (make-string columns)))
(substring-image! string start end
image 0 columns
- tab-width start-column substring-image-results)
+ tab-width start-column substring-image-results
+ char-image-strings)
image)))
(define substring-image-results
(define (group-image! group start end
image image-start image-end
- tab-width column-offset results)
- (let ((text (group-text group))
- (gap-start (group-gap-start group))
- (gap-end (group-gap-end group))
+ tab-width column-offset results
+ char-image-strings)
+ (let ((text (group-text group))
+ (gap-start (group-gap-start group))
+ (gap-end (group-gap-end group))
(gap-length (group-gap-length group)))
(cond ((fix:<= end gap-start)
(substring-image! text start end
image image-start image-end
- tab-width column-offset results))
+ tab-width column-offset results
+ char-image-strings))
((fix:<= gap-start start)
(substring-image! text
(fix:+ start gap-length) (fix:+ end gap-length)
image image-start image-end
- tab-width column-offset results)
+ tab-width column-offset results
+ char-image-strings)
(vector-set! results 0 (fix:- (vector-ref results 0) gap-length)))
(else
(substring-image! text start gap-start
image image-start image-end
- tab-width column-offset results)
+ tab-width column-offset results
+ char-image-strings)
(if (fix:< (vector-ref results 1) image-end)
(begin
(substring-image! text gap-end (fix:+ end gap-length)
image (vector-ref results 1) image-end
- tab-width column-offset results)
+ tab-width column-offset results
+ char-image-strings)
(vector-set! results 0
(fix:- (vector-ref results 0) gap-length))))))))
-(define (partial-image! char n image image-start image-end tab-width)
+(define (partial-image! char n image image-start image-end tab-width
+ char-image-strings)
;; Assume that (< IMAGE-START IMAGE-END) and that N is less than the
;; total width of the image for the character.
(let ((ascii (char->integer char)))
- (cond ((fix:< ascii #o040)
- (if (and (fix:= ascii (char->integer #\tab)) tab-width)
- (let ((end
- (let ((end (fix:+ image-start n)))
- (if (fix:< end image-end) end image-end))))
- (do ((image-index image-start (fix:+ image-index 1)))
- ((fix:= image-index end))
- (string-set! image image-index #\space)))
- (vector-8b-set! image image-start (fix:+ ascii #o100))))
- ((fix:= ascii #o177)
- (string-set! image image-start #\?))
- (else
- (let ((q (fix:quotient ascii 8)))
- (let ((d1 (fix:+ (fix:quotient q 8) (char->integer #\0)))
- (d2 (fix:+ (fix:remainder q 8) (char->integer #\0)))
- (d3 (fix:+ (fix:remainder ascii 8) (char->integer #\0))))
- (case n
- ((1)
- (vector-8b-set! image image-start d3))
- ((2)
- (vector-8b-set! image image-start d2)
- (if (fix:< (fix:+ image-start 1) image-end)
- (vector-8b-set! image (fix:+ image-start 1) d3)))
- (else
- (vector-8b-set! image image-start d1)
- (if (fix:< (fix:+ image-start 1) image-end)
- (vector-8b-set! image (fix:+ image-start 1) d2))
- (if (fix:< (fix:+ image-start 2) image-end)
- (vector-8b-set! image (fix:+ image-start 2) d3))))))))))
\ No newline at end of file
+ (if (and (fix:= ascii (char->integer #\tab)) tab-width)
+ (let ((end
+ (let ((end (fix:+ image-start n)))
+ (if (fix:< end image-end) end image-end))))
+ (do ((image-index image-start (fix:+ image-index 1)))
+ ((fix:= image-index end))
+ (string-set! image image-index #\space)))
+ (let ((picture (vector-ref char-image-strings ascii)))
+ (let ((end
+ (let ((end (fix:+ image-start n)))
+ (if (fix:< end image-end) end image-end))))
+ (string-set! image image-start (string-ref picture 1))
+ (let loop ((i (fix:- (string-length picture) n))
+ (image-index image-start))
+ (if (fix:< image-index end)
+ (begin
+ (string-set! image image-index (string-ref picture i))
+ (loop (fix:+ i 1) (fix:+ image-index 1))))))))))
+
;;; -*-Scheme-*-
;;;
-;;; $Id: iserch.scm,v 1.19 1993/08/10 06:45:05 cph Exp $
+;;; $Id: iserch.scm,v 1.20 1994/09/08 20:34:04 adams Exp $
;;;
;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
"I-search"
(if (search-state-forward? state) "" " backward")
": "
- (string-image (search-state-text state) 0 false)
+ (string-image (search-state-text state) 0 false
+ default-char-image-strings)
(if invalid-regexp (string-append " [" invalid-regexp "]") ""))))
(string-set! m 0 (char-upcase (string-ref m 0)))
m)))
;;; -*-Scheme-*-
;;;
-;;; $Id: modlin.scm,v 1.18 1994/03/08 20:23:18 cph Exp $
+;;; $Id: modlin.scm,v 1.19 1994/09/08 20:34:04 adams Exp $
;;;
;;; Copyright (c) 1989-94 Massachusetts Institute of Technology
;;;
(let ((results substring-image-results))
(substring-image! string start end
line column max-end
- #f 0 results)
+ #f 0 results
+ default-char-image-strings)
(if (fix:< (vector-ref results 1) min-end)
(begin
(do ((x (vector-ref results 1) (fix:+ x 1)))
;;; -*-Scheme-*-
;;;
-;;; $Id: motion.scm,v 1.85 1993/01/12 10:50:40 cph Exp $
+;;; $Id: motion.scm,v 1.86 1994/09/08 20:34:04 adams Exp $
;;;
;;; Copyright (c) 1985, 1989-93 Massachusetts Institute of Technology
;;;
(line-start-index group index)
index
0
- (group-tab-width group))))
+ (group-tab-width group)
+ (group-char-image-strings group))))
(define (move-to-column mark column)
(let ((group (mark-group mark))
(index (mark-index mark)))
- (make-mark group
- (vector-ref (group-column->index group
- (line-start-index group index)
- (group-end-index group)
- 0
- column
- (group-tab-width group))
- 0))))
\ No newline at end of file
+ (make-mark
+ group
+ (vector-ref (group-column->index group
+ (line-start-index group index)
+ (group-end-index group)
+ 0
+ column
+ (group-tab-width group)
+ (group-char-image-strings group))
+ 0))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: struct.scm,v 1.89 1993/08/14 02:47:21 jawilson Exp $
+;;; $Id: struct.scm,v 1.90 1994/09/08 20:34:04 adams Exp $
;;;
;;; Copyright (c) 1985, 1989-93 Massachusetts Institute of Technology
;;;
(define-integrable (group-tab-width group)
(group-local-ref group (ref-variable-object tab-width)))
+(define-integrable (group-char-image-strings group)
+ (group-local-ref group (ref-variable-object char-image-strings)))
+
(define-integrable (group-case-fold-search group)
(group-local-ref group (ref-variable-object case-fold-search)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/winout.scm,v 1.8 1992/02/13 22:19:34 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/winout.scm,v 1.9 1994/09/08 20:34:04 adams Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
(char=? char #\newline)
(< (1+ (window-point-y window)) (window-y-size window)))
(window-direct-output-insert-newline! window))
- ((and (char-graphic? char)
+ ((and (not (char=? char #\newline))
+ (not (char=? char #\tab))
+ (let ((image (window-char->image window char)))
+ (and (= (string-length image) 1)
+ (char=? (string-ref image 0) char)))
+ ;; above 3 expressions replace (char-graphic? char)
(< (1+ (window-point-x window)) (window-x-size window)))
(window-direct-output-insert-char! window char))
(else
(buffer-auto-save-modified? buffer)
(or (not (window-needs-redisplay? window))
(window-direct-update! window false))
- (not (string-find-next-char-in-set string char-set:not-graphic))
+ (let loop ((i (- (string-length string) 1)))
+ (or (< i 0)
+ (let ((char (string-ref string i)))
+ (and (not (char=? char #\newline))
+ (not (char=? char #\tab))
+ (let ((image (window-char->image window char)))
+ (and (= (string-length image) 1)
+ (char=? (string-ref image 0) char)
+ (loop (- i 1))))))))
+ ;; above loop expression replaces
+ ;;(not(string-find-next-char-in-set string char-set:not-graphic))
(< (+ (string-length string) (window-point-x window))
(window-x-size window)))
(window-direct-output-insert-substring! window
projects / mit-scheme.git / commitdiff