(let ((window (screen-cursor-window screen)))
(and window (window-text-widget* window))))
-(define-integrable (car* obj) (and (pair? obj) (car obj)))
+(declare (integrate-operator car*))
+(define (car* obj) (and (pair? obj) (car obj)))
-(define-integrable (cdr* obj) (and (pair? obj) (cdr obj)))
+(declare (integrate-operator cdr*))
+(define (cdr* obj) (and (pair? obj) (cdr obj)))
(define-method set-screen-size! ((screen <gtk-screen>) x-size y-size)
(%trace "; (set-screen-size! <gtk-screen>) "screen" "x-size"x"y-size"\n")
0
(line->row line widget screen))))))
-(define-integrable (line->row line widget screen)
+(declare (integrate-operator line->row))
+(define (line->row line widget screen)
(let ((view (fix-layout-view widget))
(row-height (fix:+ (gtk-screen-line-spacing screen)
(gtk-screen-line-height screen))))
(%trace-buttons "index at "(fix:quotient drawing-x column-width)": "index)
(make-mark (buffer-group buffer) index))))))))))
-(define-integrable (update-start-mark widget)
+(declare (integrate-operator update-start-mark))
+(define (update-start-mark widget)
;; Set WIDGET's window's start-mark to the start of the first
;; completely visible line ink.
(let ((line (find-line-after (fix-rect-y (fix-layout-view widget)) widget)))
(move-mark-to! (get-start-mark widget)
(line-start line widget))))
-(define-integrable (get-start-mark widget)
+(declare (integrate-operator get-start-mark))
+(define (get-start-mark widget)
(let ((window (frame-text-inferior (text-widget-buffer-frame widget))))
(or (%window-start-mark window)
(let ((new (mark-permanent-copy (no-line-start widget))))
;; Move WIDGET's window's point into view at the beginning of the
;; nearest (first or last) completely visible line.
- (define-integrable (move-point for/back line)
+ (declare (integrate-operator move-point))
+ (define (move-point for/back line)
(let ((window (frame-text-inferior (text-widget-buffer-frame widget))))
(%trace "; "for/back"ward to "line"\n")
(%set-window-point-index! window
(else
(%trace "; no need to move\n")))))
-(define-integrable (line-start line widget)
+(declare (integrate-operator line-start))
+(define (line-start line widget)
(if line
(line-ink-start line)
(no-line-start widget)))
(%trace2 ";block-for-event-until setting timer\n")
(register-timer-event (- time (real-time-clock))
(lambda ()
- (%trace2 ";block-for-event-until timer expired\n")
+ (%trace2
+ ";block-for-event-until timer expired\n")
(set! timeout? #t)))))
(dynamic-wind
(lambda ()
(and (pair? objects)
(car objects))))
-(define-integrable (queue/push! queue object)
+(declare (integrate-operator queue/push!))
+(define (queue/push! queue object)
(let ((next (cons object (cadr queue))))
(set-car! (cdr queue) next)
(if (not (pair? (cddr queue)))
widget new-width new-height)
(gtk-widget-queue-resize-no-redraw widget))))))))
- (define-integrable gtk-paned-pack1-if
- (named-lambda (gtk-paned-pack1-if child paned prefix)
- (%trace "; "prefix"pack1-if "child" "paned"\n")
- (if child
- (let ((existing (gtk-paned-get-child1 paned)))
- (if (and existing (not (gtk-widget-destroyed? existing)))
- (begin
- (%trace "; "prefix" replacing "existing"\n")
- (gtk-widget-destroy existing)))
- (gtk-paned-pack1 paned child 'resize #f)))))
-
- (define-integrable gtk-paned-pack2-if
- (named-lambda (gtk-paned-pack2-if child paned prefix)
- (%trace "; "prefix"pack2-if "child" "paned"\n")
- (if child
- (let ((existing (gtk-paned-get-child2 paned)))
- (if (and existing (not (gtk-widget-destroyed? existing)))
- (begin
- (%trace "; "prefix" replacing "existing"\n")
- (gtk-widget-destroy existing)))
- (gtk-paned-pack2 paned child 'resize #f)))))
+ (declare (integrate-operator gtk-paned-pack1-if))
+ (define (gtk-paned-pack1-if child paned prefix)
+ (%trace "; "prefix"pack1-if "child" "paned"\n")
+ (if child
+ (let ((existing (gtk-paned-get-child1 paned)))
+ (if (and existing (not (gtk-widget-destroyed? existing)))
+ (begin
+ (%trace "; "prefix" replacing "existing"\n")
+ (gtk-widget-destroy existing)))
+ (gtk-paned-pack1 paned child 'resize #f))))
+
+ (declare (integrate-operator gtk-paned-pack2-if))
+ (define (gtk-paned-pack2-if child paned prefix)
+ (%trace "; "prefix"pack2-if "child" "paned"\n")
+ (if child
+ (let ((existing (gtk-paned-get-child2 paned)))
+ (if (and existing (not (gtk-widget-destroyed? existing)))
+ (begin
+ (%trace "; "prefix" replacing "existing"\n")
+ (gtk-widget-destroy existing)))
+ (gtk-paned-pack2 paned child 'resize #f))))
(main))
(set-buffer-drawing-valid?! (cdr entry) #f))
(gtk-screen-drawings screen)))
-(define-integrable with-screen-in-update
- (named-lambda (with-screen-in-update screen thunk)
- (if (screen-in-update? screen)
- (error "Recursive update:" screen))
- (set-screen-in-update?! screen #t)
- (let ((v (thunk)))
- (set-screen-in-update?! screen #f)
- ;; It would be better if this happened AFTER buffer change
- ;; regions were cleared. Or use gdk-window-process-updates here?
- (for-each (lambda (buffer.drawing)
- (set-buffer-drawing-update-region! (cdr buffer.drawing) #f))
- (gtk-screen-drawings screen))
- v)))
+(declare (integrate-operator with-screen-in-update))
+(define (with-screen-in-update screen thunk)
+ (if (screen-in-update? screen)
+ (error "Recursive update:" screen))
+ (set-screen-in-update?! screen #t)
+ (let ((v (thunk)))
+ (set-screen-in-update?! screen #f)
+ ;; It would be better if this happened AFTER buffer change
+ ;; regions were cleared. Or use gdk-window-process-updates here?
+ (for-each (lambda (buffer.drawing)
+ (set-buffer-drawing-update-region! (cdr buffer.drawing) #f))
+ (gtk-screen-drawings screen))
+ v))
(define (update-blinking screen)
;; Sometimes called by a callback (i.e. without-interrupts). Frobs
(and (not (group-start-index? group index))
(char=? #\newline (group-left-char group index)))))
-(define-integrable unchanged?
- (named-lambda (unchanged? line)
- (let* ((drawing (fix-ink-drawing line))
- (update-region (buffer-drawing-update-region drawing)))
- (cond ((eq? update-region #t) #t)
- ((pair? update-region)
- (or
- (let ((change-start (car update-region))
- (line-end (line-ink-end-index line)))
- (fix:<= line-end change-start))
- (let ((change-end (cdr update-region))
- (line-start (line-ink-start-index line)))
- (fix:< change-end line-start))))
- (else
- (let ((buffer (buffer-drawing-buffer drawing)))
- (and buffer
- (let ((group (buffer-group buffer)))
- (%unchanged? line
- (group-start-changes-index group)
- (group-end-changes-index group))))))))))
-
-(define-integrable %unchanged?
- (named-lambda (%unchanged? line change-start change-end)
- (or
- ;; Common trivial case: no change = unchanged.
- (not change-start)
-
- ;; First case: the change region ends before LINE starts.
- ;;
- ;; LINE and change region may not touch. The change region may
- ;; have removed the newline before LINE, or inserted new text
- ;; after the newline, changing LINE's start.
- (let ((line-start (line-ink-start-index line)))
- (fix:< change-end line-start))
-
- ;; Second case: the change region starts after LINE ends.
- ;;
- ;; LINE must end with a newline, else a change region touching
- ;; the end is adding to the line. Rather than test for this,
- ;; consider touching lines as NOT unchanged.
- (let ((line-end (line-ink-end-index line)))
- (fix:< line-end change-start)))))
+(declare (integrate-operator unchanged?))
+(define (unchanged? line)
+ (let* ((drawing (fix-ink-drawing line))
+ (update-region (buffer-drawing-update-region drawing)))
+ (cond ((eq? update-region #t) #t)
+ ((pair? update-region)
+ (or
+ (let ((change-start (car update-region))
+ (line-end (line-ink-end-index line)))
+ (fix:<= line-end change-start))
+ (let ((change-end (cdr update-region))
+ (line-start (line-ink-start-index line)))
+ (fix:< change-end line-start))))
+ (else
+ (let ((buffer (buffer-drawing-buffer drawing)))
+ (and buffer
+ (let ((group (buffer-group buffer)))
+ (%unchanged? line
+ (group-start-changes-index group)
+ (group-end-changes-index group)))))))))
+
+(declare (integrate-operator %unchanged?))
+(define (%unchanged? line change-start change-end)
+ (or
+ ;; Common trivial case: no change = unchanged.
+ (not change-start)
+
+ ;; First case: the change region ends before LINE starts.
+ ;;
+ ;; LINE and change region may not touch. The change region may
+ ;; have removed the newline before LINE, or inserted new text
+ ;; after the newline, changing LINE's start.
+ (let ((line-start (line-ink-start-index line)))
+ (fix:< change-end line-start))
+
+ ;; Second case: the change region starts after LINE ends.
+ ;;
+ ;; LINE must end with a newline, else a change region touching
+ ;; the end is adding to the line. Rather than test for this,
+ ;; consider touching lines as NOT unchanged.
+ (let ((line-end (line-ink-end-index line)))
+ (fix:< line-end change-start))))
\f
(define (update-cursor widget)
(%trace ";\t update-cursor "widget"\n")
projects / mit-scheme.git / commitdiff