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

Added lots of without-interrupts and without-gcing to keep them from

happening at bad times.
parent 5f3d5cbf
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