ts-stream.lisp 11.2 KB
Newer Older
ram's avatar
ram committed
1 2 3
;;; -*- Package: Hemlock; Log: hemlock.log -*-
;;;
;;; **********************************************************************
4 5 6 7
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
8
  "$Header: src/hemlock/ts-stream.lisp $")
9
;;;
ram's avatar
ram committed
10 11 12 13 14 15 16 17 18
;;; **********************************************************************
;;;
;;; This file implements typescript streams.
;;;
;;; Written by William Lott.
;;;

(in-package "HEMLOCK")

19 20 21 22


;;;; Ts-streams.

ram's avatar
ram committed
23 24 25
(defconstant ts-stream-output-buffer-size 512)

(defstruct (ts-stream
dtc's avatar
dtc committed
26
	    (:include sys:lisp-stream
ram's avatar
ram committed
27 28 29 30 31 32 33 34 35 36 37
		      (in #'%ts-stream-in)
		      (out #'%ts-stream-out)
		      (sout #'%ts-stream-sout)
		      (misc #'%ts-stream-misc))
	    (:print-function %ts-stream-print)
	    (:constructor make-ts-stream (wire typescript)))
  wire
  typescript
  (output-buffer (make-string ts-stream-output-buffer-size)
		 :type simple-string)
  (output-buffer-index 0 :type fixnum)
38 39 40
  ;;
  ;; The current output character position on the line, returned by the
  ;; :CHARPOS method.
41
  (char-pos 0 :type fixnum)
42 43 44 45
  ;;
  ;; The current length of a line of output.  Returned by the :LINE-LENGTH
  ;; method.
  (line-length 80)
46 47 48 49 50
  ;;
  ;; This is a list of strings and stream-commands whose order manifests the
  ;; input provided by remote procedure calls into the slave of
  ;; TS-STREAM-ACCEPT-INPUT.
  (current-input nil :type list)
ram's avatar
ram committed
51 52 53 54 55 56
  (input-read-index 0 :type fixnum))

(defun %ts-stream-print (ts stream depth)
  (declare (ignore ts depth))
  (write-string "#<TS Stream>" stream))

57 58 59 60 61 62


;;;; Conditions.

(define-condition unexpected-stream-command (error)
  ;; Context is a string to be plugged into the report text.
63
  ((context :reader unexpected-stream-command-context :initarg :context))
64 65 66 67 68 69 70 71 72
  (:report (lambda (condition stream)
	     (format stream "~&Unexpected stream-command while ~A."
		     (unexpected-stream-command-context condition)))))



;;;; Editor remote calls into slave.

;;; TS-STREAM-ACCEPT-INPUT -- Internal Interface.
ram's avatar
ram committed
73
;;;
74 75 76
;;; The editor calls this remotely in the slave to indicate that the user has
;;; provided input.  Input is a string, symbol, or list.  If it is a list, the
;;; the CAR names the command, and the CDR is the arguments.
ram's avatar
ram committed
77
;;;
78
(defun ts-stream-accept-input (remote input)
ram's avatar
ram committed
79 80
  (let ((stream (wire:remote-object-value remote)))
    (system:without-interrupts
81
     (system:without-gcing
ram's avatar
ram committed
82 83
      (setf (ts-stream-current-input stream)
	    (nconc (ts-stream-current-input stream)
84
		   (list (etypecase input
85 86 87 88 89 90 91 92
			   (string
			    (let ((newline
				   (position #\newline input :from-end t)))
			      (setf (ts-stream-char-pos stream)
				    (if newline
					(- (length input) newline 1)
					(length input)))
			      input))
93 94 95 96 97
			   (cons
			    (ext:make-stream-command (car input)
						     (cdr input)))
			   (symbol
			    (ext:make-stream-command input)))))))))
ram's avatar
ram committed
98 99
  nil)

100
;;; TS-STREAM-SET-LINE-LENGTH -- Internal Interface.
101 102 103 104 105 106 107 108
;;;
;;; This function is called by the editor to indicate that the line-length for
;;; a TS stream should now be Length.
;;;
(defun ts-stream-set-line-length (remote length)
  (let ((stream (wire:remote-object-value remote)))
    (setf (ts-stream-line-length stream) length)))

109 110 111 112 113


;;;; Stream methods.

;;; %TS-STREAM-LISTEN -- Internal.
ram's avatar
ram committed
114 115 116 117 118 119
;;;
;;; Determine if there is any input available.  If we don't think so, process
;;; all pending events, and look again.
;;; 
(defun %ts-stream-listen (stream)
  (flet ((check ()
120 121 122
	   (system:without-interrupts
	    (system:without-gcing
	     (loop
123 124
	       (let* ((current (ts-stream-current-input stream))
		      (first (first current)))
125 126
		 (cond ((null current)
			(return nil))
127 128
		       ((ext:stream-command-p first)
			(return t))
129
		       ((>= (ts-stream-input-read-index stream)
130
			    (length (the simple-string first)))
131 132 133 134
			(pop (ts-stream-current-input stream))
			(setf (ts-stream-input-read-index stream) 0))
		       (t
			(return t)))))))))
ram's avatar
ram committed
135 136 137 138 139
    (or (check)
	(progn
	  (system:serve-all-events 0)
	  (check)))))

140
;;; %TS-STREAM-IN -- Internal.
ram's avatar
ram committed
141 142 143 144 145 146 147
;;;
;;; The READ-CHAR stream method.
;;; 
(defun %ts-stream-in (stream &optional eoferr eofval)
  (declare (ignore eoferr eofval)) ; EOF's are impossible.
  (wait-for-typescript-input stream)
  (system:without-interrupts
148
   (system:without-gcing
149 150 151 152 153 154 155 156
    (let ((first (first (ts-stream-current-input stream))))
      (etypecase first
	(string
	 (prog1 (schar first (ts-stream-input-read-index stream))
	   (incf (ts-stream-input-read-index stream))))
	(ext:stream-command
	 (error 'unexpected-stream-command
		:context "in the READ-CHAR method")))))))
ram's avatar
ram committed
157

158
;;; %TS-STREAM-READ-LINE -- Internal.
ram's avatar
ram committed
159 160 161 162 163 164
;;;
;;; The READ-LINE stream method.  Note: here we take advantage of the fact that
;;; newlines will only appear at the end of strings.
;;; 
(defun %ts-stream-read-line (stream eoferr eofval)
  (declare (ignore eoferr eofval))
165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181
  (macrolet
      ((next-str ()
	 '(progn
	    (wait-for-typescript-input stream)
	    (system:without-interrupts
	     (system:without-gcing
	      (let ((first (first (ts-stream-current-input stream))))
		(etypecase first
		  (string
		   (prog1 (if (zerop (ts-stream-input-read-index stream))
			      (pop (ts-stream-current-input stream))
			      (subseq (pop (ts-stream-current-input stream))
				      (ts-stream-input-read-index stream)))
		     (setf (ts-stream-input-read-index stream) 0)))
		  (ext:stream-command
		   (error 'unexpected-stream-command
			  :context "in the READ-CHAR method")))))))))
ram's avatar
ram committed
182 183 184 185 186 187
    (do ((result (next-str) (concatenate 'simple-string result (next-str))))
	((char= (schar result (1- (length result))) #\newline)
	 (values (subseq result 0 (1- (length result)))
		 nil))
      (declare (simple-string result)))))

188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204
;;; WAIT-FOR-TYPESCRIPT-INPUT -- Internal.
;;;
;;; Keep calling server until some input shows up.
;;; 
(defun wait-for-typescript-input (stream)
  (unless (%ts-stream-listen stream)
    (let ((wire (ts-stream-wire stream))
	  (ts (ts-stream-typescript stream)))
      (system:without-interrupts
       (system:without-gcing
	(wire:remote wire (ts-buffer-ask-for-input ts))
	(wire:wire-force-output wire)))
      (loop
	(system:serve-all-events)
	(when (%ts-stream-listen stream)
	  (return))))))

ram's avatar
ram committed
205 206
;;; %TS-STREAM-FLSBUF --- internal.
;;;
207 208
;;; Flush the output buffer associated with stream.  This should only be used
;;; inside a without-interrupts and without-gcing.
ram's avatar
ram committed
209 210 211 212 213 214
;;; 
(defun %ts-stream-flsbuf (stream)
  (when (and (ts-stream-wire stream)
	     (ts-stream-output-buffer stream)
	     (not (zerop (ts-stream-output-buffer-index stream))))
    (wire:remote (ts-stream-wire stream)
215 216 217 218 219 220
      (ts-buffer-output-string
       (ts-stream-typescript stream)
       (subseq (the simple-string (ts-stream-output-buffer stream))
	       0
	       (ts-stream-output-buffer-index stream))))
    (setf (ts-stream-output-buffer-index stream) 0)))
ram's avatar
ram committed
221 222 223 224 225 226

;;; %TS-STREAM-OUT --- internal.
;;;
;;; Output a single character to stream.
;;;
(defun %ts-stream-out (stream char)
wlott's avatar
wlott committed
227
  (declare (base-char char))
228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243
  (system:without-interrupts
   (system:without-gcing
    (when (= (ts-stream-output-buffer-index stream)
	     ts-stream-output-buffer-size)
      (%ts-stream-flsbuf stream))
    (setf (schar (ts-stream-output-buffer stream)
		 (ts-stream-output-buffer-index stream))
	  char)
    (incf (ts-stream-output-buffer-index stream))
    (incf (ts-stream-char-pos stream))
    (when (= (char-code char)
	     (char-code #\Newline))
      (%ts-stream-flsbuf stream)
      (setf (ts-stream-char-pos stream) 0)
      (wire:wire-force-output (ts-stream-wire stream)))
    char)))
ram's avatar
ram committed
244 245 246 247 248 249 250 251 252 253 254 255

;;; %TS-STREAM-SOUT --- internal.
;;;
;;; Output a string to stream.
;;; 
(defun %ts-stream-sout (stream string start end)
  (declare (simple-string string))
  (declare (fixnum start end))
  (let ((wire (ts-stream-wire stream))
	(newline (position #\Newline string :start start :end end :from-end t))
	(length (- end start)))
    (when wire
256 257 258 259 260
      (system:without-interrupts
       (system:without-gcing
	(let ((index (ts-stream-output-buffer-index stream)))
	  (cond ((> (+ index length)
		    ts-stream-output-buffer-size)
ram's avatar
ram committed
261
		 (%ts-stream-flsbuf stream)
262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283
		 (wire:remote wire
		   (ts-buffer-output-string (ts-stream-typescript stream)
					    (subseq string start end)))
		 (when newline
		   (wire:wire-force-output wire)))
		(t
		 (replace (the simple-string (ts-stream-output-buffer stream))
			  string
			  :start1 index
			  :end1 (+ index length)
			  :start2 start
			  :end2 end)
		 (incf (ts-stream-output-buffer-index stream)
		       length)
		 (when newline
		   (%ts-stream-flsbuf stream)
		   (wire:wire-force-output wire)))))
	(setf (ts-stream-char-pos stream)
	      (if newline
		  (- end newline 1)
		  (+ (ts-stream-char-pos stream)
		     length))))))))
ram's avatar
ram committed
284

285
;;; %TS-STREAM-UNREAD -- Internal.
ram's avatar
ram committed
286 287 288 289 290
;;;
;;; Unread a single character.
;;; 
(defun %ts-stream-unread (stream char)
  (system:without-interrupts
291
   (system:without-gcing
292 293 294 295 296 297 298 299
    (let ((first (first (ts-stream-current-input stream))))
      (cond ((and (stringp first)
		  (> (ts-stream-input-read-index stream) 0))
	     (setf (schar first (decf (ts-stream-input-read-index stream)))
		   char))
	    (t
	     (push (string char) (ts-stream-current-input stream))
	     (setf (ts-stream-input-read-index stream) 0)))))))
ram's avatar
ram committed
300 301 302 303 304 305 306 307 308 309

;;; %TS-STREAM-CLOSE --- internal.
;;;
;;; Can't do much, 'cause the wire is shared.
;;; 
(defun %ts-stream-close (stream abort)
  (unless abort
    (force-output stream))
  (lisp::set-closed-flame stream))

310
;;; %TS-STREAM-CLEAR-INPUT -- Internal.
ram's avatar
ram committed
311 312 313 314 315
;;;
;;; Pass the request to the editor and clear any buffered input.
;;;
(defun %ts-stream-clear-input (stream)
  (system:without-interrupts
316 317 318 319
   (system:without-gcing
    (when (ts-stream-wire stream)
      (wire:remote-value (ts-stream-wire stream)
	(ts-buffer-clear-input (ts-stream-typescript stream))))
ram's avatar
ram committed
320
    (setf (ts-stream-current-input stream) nil
321
	  (ts-stream-input-read-index stream) 0))))
ram's avatar
ram committed
322

323
;;; %TS-STREAM-MISC -- Internal.
ram's avatar
ram committed
324 325 326 327 328 329 330 331 332 333 334
;;;
;;; The misc stream method.
;;; 
(defun %ts-stream-misc (stream operation &optional arg1 arg2)
  (case operation
    (:read-line
     (%ts-stream-read-line stream arg1 arg2))
    (:listen
     (%ts-stream-listen stream))
    (:unread
     (%ts-stream-unread stream arg1))
335
    (:interactive-p t)
336 337 338 339 340 341 342 343 344
    (:get-command
     (wait-for-typescript-input stream)
     (system:without-interrupts
      (system:without-gcing
       (etypecase (first (ts-stream-current-input stream))
	 (stream-command
	  (setf (ts-stream-input-read-index stream) 0)
	  (pop (ts-stream-current-input stream)))
	 (string nil)))))
ram's avatar
ram committed
345 346 347 348 349 350 351
    (:close
     (%ts-stream-close stream arg1))
    (:clear-input
     (%ts-stream-clear-input stream)
     t)
    (:finish-output
     (when (ts-stream-wire stream)
352 353 354 355 356 357 358 359
       (system:without-interrupts
	(system:without-gcing
	 (%ts-stream-flsbuf stream)
	 ;; Note: for the return value to come back,
	 ;; all pending RPCs must have completed.
	 ;; Therefore, we know it has synced.
	 (wire:remote-value (ts-stream-wire stream)
	   (ts-buffer-finish-output (ts-stream-typescript stream))))))
ram's avatar
ram committed
360 361 362
     t)
    (:force-output
     (when (ts-stream-wire stream)
363 364 365 366
       (system:without-interrupts
	(system:without-gcing
	 (%ts-stream-flsbuf stream)
	 (wire:wire-force-output (ts-stream-wire stream)))))
ram's avatar
ram committed
367 368 369 370 371
     t)
    (:clear-output
     (setf (ts-stream-output-buffer-index stream) 0)
     t)
    (:element-type
wlott's avatar
wlott committed
372
     'base-char)
ram's avatar
ram committed
373 374 375
    (:charpos
     (ts-stream-char-pos stream))
    (:line-length
376
     (ts-stream-line-length stream))))