From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 10 Feb 2019 22:39:59 +0000 (+0000)
Subject: Convert multi-LETREC to internal definitions in edwin/tterm.scm.
X-Git-Tag: mit-scheme-pucked-10.1.10~6^2~7^2~2
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=33451c6d93f2d5437b88ef8d5a78c1759dd5fc25;p=mit-scheme.git

Convert multi-LETREC to internal definitions in edwin/tterm.scm.
---

diff --git a/src/edwin/tterm.scm b/src/edwin/tterm.scm
index 28d1d6c8a..5b81cc181 100644
--- a/src/edwin/tterm.scm
+++ b/src/edwin/tterm.scm
@@ -183,173 +183,180 @@ USA.
 	;; subsequent read do not EACH wait a little-while.
         (incomplete-pending #F))
 
-    (letrec
-        ((match-key			; -> match: #F or char or (seq . name)
-	  (named-lambda (match-key)
-	    (and (fix:< start end)
-		 terminal-state
-		 (let ((n-chars (fix:- end start)))
-		   (let find
-		       ((key-pairs (terminal-state/key-table terminal-state))
-			(possible-pending? #f))
-		     (if (null? key-pairs)
-			 (begin
-			   (if (number? incomplete-pending)
-			       (if (or (not possible-pending?)
-				       (> (real-time-clock)
-					  incomplete-pending))
-				   (set! incomplete-pending #t)))
-			   (if (number? incomplete-pending)
-			       #f
-			       (vector-8b-ref buffer start)))
-			 (let* ((key-seq  (caar key-pairs))
-				(n-seq    (string-length key-seq)))
-			   (cond ((and (fix:<= n-seq n-chars)
-				       (substring=? buffer start
-						    (fix:+ start n-seq)
-						    key-seq 0 n-seq))
-				  (car key-pairs))
-				 ((and (fix:> n-seq n-chars)
-				       (substring=? buffer start
-						    (fix:+ start n-chars)
-						    key-seq 0 n-chars))
-				  (if (not incomplete-pending)
-				      (set! incomplete-pending
-					    (+ (real-time-clock)
-					       little-while)))
-				  (find (cdr key-pairs) #T))
-				 (else
-				  (find (cdr key-pairs)
-					possible-pending?))))))))))
-	 (read-more?			; -> #F or #T if some octets were read
-	  (named-lambda (read-more?)
-	    (let ((n (%channel-read channel buffer end input-buffer-size)))
-	      (cond ((not n)  #f)
-		    ((eq? n #t) #f)
-		    ((fix:> n 0)
-		     (set! end (fix:+ end n))
-		     #t)
-		    ((fix:= n 0)
-		     ;;(error "Reached EOF in keyboard input.")
-		     #f)))))
-	 (match-event	; -> #F or match (char or pair) or input event
-	  (named-lambda (match-event block?)
-	    (let loop ()
-	      (or (begin
-		    (read-more?)
-		    (match-key))
-		  ;; Poll event sources and block.
-		  (begin
-		    (cond (inferior-thread-changes?
-			   (or (->update-event (accept-thread-output))
-			       (loop)))
-			  ((process-output-available?)
-			   (or (->update-event (accept-process-output))
-			       (loop)))
-			  ((process-status-changes?)
-			   (or (->update-event (handle-process-status-changes))
-			       (loop)))
-			  ((not have-select?)
-			   (and block? (loop)))
-			  (incomplete-pending
-			   ;; Must busy-wait.
-			   (loop))
-			  (block?
-			   (block-for-event)
-			   (loop))
-			  (else
-			   #f)))))))
-	 (->update-event
-	  (named-lambda (->update-event redisplay?)
-	    (and redisplay?
-		 (make-input-event
-		  (if (eq? redisplay? 'force-return) 'return 'update)
-		  update-screens! #f))))
-	 (consume-match!
-	  (named-lambda (consume-match! match)
-	    (cond ((fixnum? match)
-		   (set! start (fix:1+ start)))
-		  ((input-event? match)
-		   unspecific)
-		  ((pair? match)
-		   (set! start (fix:+ start (string-length (car match)))))
-		  (else (error "Inedible match:" match)))
-	    (if (fix:< end start)
-		(error "Overconsumption:" buffer start end match))
-	    (cond ((fix:= start end)	; all consumed
-		   (if (not (fix:zero? start))
-		       (set! start 0))
-		   (if (not (fix:zero? end))
-		       (set! end 0)))
-		  ((fix:>= start input-buffer-size)
-		   (substring-move-left! buffer start end buffer 0)
-		   (set! end (fix:- end start))
-		   (set! start 0)))
-	    (set! incomplete-pending #f)))
-	 (->event
-	  (named-lambda (->event match)
-	    (cond ((eq? match #f)
-		   #F)
-		  ((fixnum? match)
-		   ;; Assume the eighth bit is a meta bit.
-		   (if (fix:< match #x80)
-		       (make-char match 0)
-		       (make-char (fix:and match #x7F) char-bit:meta)))
-		  ((input-event? match)
-		   match)
-		  ((pair? match)
-		   (cdr match))
-		  (else (error "Bogus input match:" match)))))
-	 (block-for-event
-	  (named-lambda (block-for-event)
-	    (let ((input-available? #f)
-		  (output-available? #f)
-		  (registrations))
-	      (dynamic-wind
-	       (lambda ()
-		 (let ((thread (current-thread)))
-		   (set! registrations
-			 (cons
-			  (register-io-thread-event
-			   (channel-descriptor-for-select channel) 'read
-			   thread (lambda (mode)
-				    mode
-				    (set! input-available? #t)))
-			  (register-process-output-events
-			   thread (lambda (mode)
-				    mode
-				    (set! output-available? #t)))))))
-	       (lambda ()
-		 (with-thread-events-blocked
-		  (lambda ()
-		    (if (and (not input-available?)
-			     (not output-available?)
-			     (not (process-status-changes?))
-			     (not inferior-thread-changes?))
-			(suspend-current-thread))))
-		 unspecific)
-	       (lambda ()
-		 (for-each deregister-io-thread-event registrations)))))))
-      (values
-       (named-lambda (halt-update?)
-	 (or (fix:< start end)
-	     (read-more?)))
-       (named-lambda (peek-no-hang timeout)
-	 (keyboard-peek-busy-no-hang
+    ;; Internal subroutines.
+
+    (define (match-key)			; -> match: #F or char or (seq . name)
+      (and (fix:< start end)
+	   terminal-state
+	   (let ((n-chars (fix:- end start)))
+	     (let find
+		 ((key-pairs (terminal-state/key-table terminal-state))
+		  (possible-pending? #f))
+	       (if (null? key-pairs)
+		   (begin
+		     (if (number? incomplete-pending)
+			 (if (or (not possible-pending?)
+				 (> (real-time-clock)
+				    incomplete-pending))
+			     (set! incomplete-pending #t)))
+		     (if (number? incomplete-pending)
+			 #f
+			 (vector-8b-ref buffer start)))
+		   (let* ((key-seq  (caar key-pairs))
+			  (n-seq    (string-length key-seq)))
+		     (cond ((and (fix:<= n-seq n-chars)
+				 (substring=? buffer start
+					      (fix:+ start n-seq)
+					      key-seq 0 n-seq))
+			    (car key-pairs))
+			   ((and (fix:> n-seq n-chars)
+				 (substring=? buffer start
+					      (fix:+ start n-chars)
+					      key-seq 0 n-chars))
+			    (if (not incomplete-pending)
+				(set! incomplete-pending
+				      (+ (real-time-clock)
+					 little-while)))
+			    (find (cdr key-pairs) #T))
+			   (else
+			    (find (cdr key-pairs)
+				  possible-pending?)))))))))
+
+    (define (read-more?)		; -> #F or #T if some octets were read
+      (let ((n (%channel-read channel buffer end input-buffer-size)))
+	(cond ((not n)  #f)
+	      ((eq? n #t) #f)
+	      ((fix:> n 0)
+	       (set! end (fix:+ end n))
+	       #t)
+	      ((fix:= n 0)
+	       ;;(error "Reached EOF in keyboard input.")
+	       #f))))
+
+    (define (match-event block?) ; -> #F or match (char or pair) or input event
+      (let loop ()
+	(or (begin
+	      (read-more?)
+	      (match-key))
+	    ;; Poll event sources and block.
+	    (begin
+	      (cond (inferior-thread-changes?
+		     (or (->update-event (accept-thread-output))
+			 (loop)))
+		    ((process-output-available?)
+		     (or (->update-event (accept-process-output))
+			 (loop)))
+		    ((process-status-changes?)
+		     (or (->update-event (handle-process-status-changes))
+			 (loop)))
+		    ((not have-select?)
+		     (and block? (loop)))
+		    (incomplete-pending
+		     ;; Must busy-wait.
+		     (loop))
+		    (block?
+		     (block-for-event)
+		     (loop))
+		    (else
+		     #f))))))
+
+    (define (->update-event redisplay?)
+      (and redisplay?
+	   (make-input-event
+	    (if (eq? redisplay? 'force-return) 'return 'update)
+	    update-screens! #f)))
+
+    (define (consume-match! match)
+      (cond ((fixnum? match)
+	     (set! start (fix:1+ start)))
+	    ((input-event? match)
+	     unspecific)
+	    ((pair? match)
+	     (set! start (fix:+ start (string-length (car match)))))
+	    (else (error "Inedible match:" match)))
+      (if (fix:< end start)
+	  (error "Overconsumption:" buffer start end match))
+      (cond ((fix:= start end)		; all consumed
+	     (if (not (fix:zero? start))
+		 (set! start 0))
+	     (if (not (fix:zero? end))
+		 (set! end 0)))
+	    ((fix:>= start input-buffer-size)
+	     (substring-move-left! buffer start end buffer 0)
+	     (set! end (fix:- end start))
+	     (set! start 0)))
+      (set! incomplete-pending #f))
+
+    (define (->event match)
+      (cond ((eq? match #f)
+	     #F)
+	    ((fixnum? match)
+	     ;; Assume the eighth bit is a meta bit.
+	     (if (fix:< match #x80)
+		 (make-char match 0)
+		 (make-char (fix:and match #x7F) char-bit:meta)))
+	    ((input-event? match)
+	     match)
+	    ((pair? match)
+	     (cdr match))
+	    (else (error "Bogus input match:" match))))
+
+    (define (block-for-event)
+      (let ((input-available? #f)
+	    (output-available? #f)
+	    (registrations))
+	(dynamic-wind
+	  (lambda ()
+	    (let ((thread (current-thread)))
+	      (set! registrations
+		    (cons
+		     (register-io-thread-event
+		      (channel-descriptor-for-select channel) 'read
+		      thread (lambda (mode)
+			       mode
+			       (set! input-available? #t)))
+		     (register-process-output-events
+		      thread (lambda (mode)
+			       mode
+			       (set! output-available? #t)))))))
 	  (lambda ()
-	    (let ((event (->event (match-event #f))))
-	      (if (input-event? event)
-		  (begin
-		    (apply-input-event event)
-		    #f)
-		  event)))
-	  timeout))
-       (named-lambda (peek)
-	 (->event (match-event #t)))
-       (named-lambda (read)
-	 (let ((match (match-event #t)))
-	   (consume-match! match)
-	   (->event match)))))))
+	    (with-thread-events-blocked
+	      (lambda ()
+		(if (and (not input-available?)
+			 (not output-available?)
+			 (not (process-status-changes?))
+			 (not inferior-thread-changes?))
+		    (suspend-current-thread))))
+	    unspecific)
+	  (lambda ()
+	    (for-each deregister-io-thread-event registrations)))))
+
+    ;; Exposed operations.
+
+    (define (halt-update?)
+      (or (fix:< start end)
+	  (read-more?)))
+
+    (define (peek-no-hang timeout)
+      (keyboard-peek-busy-no-hang
+       (lambda ()
+	 (let ((event (->event (match-event #f))))
+	   (if (input-event? event)
+	       (begin
+		 (apply-input-event event)
+		 #f)
+	       event)))
+       timeout))
+
+    (define (peek)
+      (->event (match-event #t)))
+
+    (define (read)
+      (let ((match (match-event #t)))
+	(consume-match! match)
+	(->event match)))
+
+    (values halt-update? peek-no-hang peek read)))
 
 (define-integrable input-buffer-size 16)