From e5212b591787a0e4176efdd6e58c069c789293a4 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Wed, 14 Mar 2018 16:12:48 -0700 Subject: [PATCH] gtk-screen: Reform use of define-integrable. --- src/gtk-screen/gtk-screen.scm | 179 ++++++++++++++++++---------------- 1 file changed, 94 insertions(+), 85 deletions(-) diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm index 1d8d6f1de..1c9337a96 100644 --- a/src/gtk-screen/gtk-screen.scm +++ b/src/gtk-screen/gtk-screen.scm @@ -187,9 +187,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 ) x-size y-size) (%trace "; (set-screen-size! ) "screen" "x-size"x"y-size"\n") @@ -394,7 +396,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. 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)))) @@ -463,14 +466,16 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%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)))) @@ -485,7 +490,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;; 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 @@ -504,7 +510,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -572,7 +579,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%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 () @@ -667,7 +675,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -1086,27 +1095,27 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. 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)) @@ -1596,19 +1605,19 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -2370,48 +2379,48 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)))) (define (update-cursor widget) (%trace ";\t update-cursor "widget"\n") -- 2.25.1