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")

chiles's avatar
chiles committed
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.
chiles's avatar
chiles committed
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)
chiles's avatar
chiles committed
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))

chiles's avatar
chiles committed
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))
chiles's avatar
chiles committed
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
;;;
chiles's avatar
chiles committed
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
;;;
chiles's avatar
chiles committed
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)
chiles's avatar
chiles committed
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))
chiles's avatar
chiles committed
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)

chiles's avatar
chiles committed
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)))

chiles's avatar
chiles committed
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
chiles's avatar
chiles committed
123 124
	       (let* ((current (ts-stream-current-input stream))
		      (first (first current)))
125 126
		 (cond ((null current)
			(return nil))
chiles's avatar
chiles committed
127 128
		       ((ext:stream-command-p first)
			(return t))
129
		       ((>= (ts-stream-input-read-index stream)
chiles's avatar
chiles committed
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)))))

chiles's avatar
chiles committed
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
chiles's avatar
chiles committed
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

chiles's avatar
chiles committed
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))
chiles's avatar
chiles committed
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)))))

chiles's avatar
chiles committed
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)
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

chiles's avatar
chiles committed
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
chiles's avatar
chiles committed
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))

chiles's avatar
chiles committed
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

chiles's avatar
chiles committed
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)
chiles's avatar
chiles committed
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
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))))