Skip to content
Snippets Groups Projects
Commit f10b47c3 authored by wlott's avatar wlott
Browse files

This commit was generated by cvs2svn to compensate for changes in r2693,

which included commits to RCS files with non-trunk default branches.
parents 8b17aa6b d9e3e045
No related branches found
No related tags found
No related merge requests found
......@@ -46,10 +46,11 @@
(defun ts-stream-accept-input (remote string)
(let ((stream (wire:remote-object-value remote)))
(system:without-interrupts
(system:without-gcing
(setf (ts-stream-current-input stream)
(nconc (ts-stream-current-input stream)
(list string)))
(setf (ts-stream-char-pos stream) 0)))
(setf (ts-stream-char-pos stream) 0))))
nil)
;;; %TS-STREAM-LISTEN --- internal.
......@@ -59,17 +60,18 @@
;;;
(defun %ts-stream-listen (stream)
(flet ((check ()
(system:without-interrupts
(loop
(let ((current (ts-stream-current-input stream)))
(cond ((null current)
(return nil))
((>= (ts-stream-input-read-index stream)
(length (the simple-string (car current))))
(pop (ts-stream-current-input stream))
(setf (ts-stream-input-read-index stream) 0))
(t
(return t))))))))
(system:without-interrupts
(system:without-gcing
(loop
(let ((current (ts-stream-current-input stream)))
(cond ((null current)
(return nil))
((>= (ts-stream-input-read-index stream)
(length (the simple-string (car current))))
(pop (ts-stream-current-input stream))
(setf (ts-stream-input-read-index stream) 0))
(t
(return t)))))))))
(or (check)
(progn
(system:serve-all-events 0)
......@@ -83,9 +85,10 @@
(unless (%ts-stream-listen stream)
(let ((wire (ts-stream-wire stream))
(ts (ts-stream-typescript stream)))
(wire:remote wire
(ts-buffer-ask-for-input ts))
(wire:wire-force-output wire)
(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)
......@@ -99,12 +102,11 @@
(declare (ignore eoferr eofval)) ; EOF's are impossible.
(wait-for-typescript-input stream)
(system:without-interrupts
(prog1
(schar (car (ts-stream-current-input stream))
(ts-stream-input-read-index stream))
(incf (ts-stream-input-read-index stream)))))
(system:without-gcing
(prog1
(schar (car (ts-stream-current-input stream))
(ts-stream-input-read-index stream))
(incf (ts-stream-input-read-index stream))))))
;;; %TS-STREAM-READ-LINE --- internal.
;;;
......@@ -117,12 +119,13 @@
'(progn
(wait-for-typescript-input stream)
(system:without-interrupts
(system:without-gcing
(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))))))
(setf (ts-stream-input-read-index stream) 0)))))))
(do ((result (next-str) (concatenate 'simple-string result (next-str))))
((char= (schar result (1- (length result))) #\newline)
(values (subseq result 0 (1- (length result)))
......@@ -131,20 +134,20 @@
;;; %TS-STREAM-FLSBUF --- internal.
;;;
;;; Flush the output buffer associated with stream.
;;; Flush the output buffer associated with stream. This should only be used
;;; inside a without-interrupts and without-gcing.
;;;
(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)
(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)))
(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)))
;;; %TS-STREAM-OUT --- internal.
;;;
......@@ -152,20 +155,22 @@
;;;
(defun %ts-stream-out (stream char)
(declare (base-character char))
(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)
(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)))
;;; %TS-STREAM-SOUT --- internal.
;;;
......@@ -178,32 +183,34 @@
(newline (position #\Newline string :start start :end end :from-end t))
(length (- end start)))
(when wire
(let ((index (ts-stream-output-buffer-index stream)))
(cond ((> (+ index length)
ts-stream-output-buffer-size)
(%ts-stream-flsbuf stream)
(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
(system:without-interrupts
(system:without-gcing
(let ((index (ts-stream-output-buffer-index stream)))
(cond ((> (+ index length)
ts-stream-output-buffer-size)
(%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)))))
(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))))))))
;;; %TS-STREAM-UNREAD --- internal.
;;;
......@@ -211,6 +218,7 @@
;;;
(defun %ts-stream-unread (stream char)
(system:without-interrupts
(system:without-gcing
(cond ((and (ts-stream-current-input stream)
(> (ts-stream-input-read-index stream) 0))
(setf (schar (car (ts-stream-current-input stream))
......@@ -218,7 +226,7 @@
char))
(t
(push (string char) (ts-stream-current-input stream))
(setf (ts-stream-input-read-index stream) 0)))))
(setf (ts-stream-input-read-index stream) 0))))))
;;; %TS-STREAM-CLOSE --- internal.
;;;
......@@ -234,12 +242,13 @@
;;; Pass the request to the editor and clear any buffered input.
;;;
(defun %ts-stream-clear-input (stream)
(when (ts-stream-wire stream)
(wire:remote-value (ts-stream-wire stream)
(ts-buffer-clear-input (ts-stream-typescript stream))))
(system:without-interrupts
(system:without-gcing
(when (ts-stream-wire stream)
(wire:remote-value (ts-stream-wire stream)
(ts-buffer-clear-input (ts-stream-typescript stream))))
(setf (ts-stream-current-input stream) nil
(ts-stream-input-read-index stream) 0)))
(ts-stream-input-read-index stream) 0))))
;;; %TS-STREAM-MISC --- internal.
;;;
......@@ -260,24 +269,31 @@
t)
(:finish-output
(when (ts-stream-wire stream)
(%ts-stream-flsbuf stream)
;; Note: for the return value to come back,
;; all pending RPCs must have completed.
(wire:remote-value (ts-stream-wire stream)
(ts-buffer-finish-output (ts-stream-typescript stream))))
(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))))))
t)
(:force-output
(when (ts-stream-wire stream)
(%ts-stream-flsbuf stream)
(wire:wire-force-output (ts-stream-wire stream)))
(system:without-interrupts
(system:without-gcing
(%ts-stream-flsbuf stream)
(wire:wire-force-output (ts-stream-wire stream)))))
t)
(:clear-output
(setf (ts-stream-output-buffer-index stream) 0)
t)
(:element-type
'char-string)
'base-character)
(:charpos
(ts-stream-char-pos stream))
(:line-length
(wire:remote-value (ts-stream-wire stream)
(ts-buffer-line-length (ts-stream-typescript stream))))))
(system:without-interrupts
(system:without-gcing
(wire:remote-value (ts-stream-wire stream)
(ts-buffer-line-length (ts-stream-typescript stream))))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment