Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
d9e3e045
Commit
d9e3e045
authored
34 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
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
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
hemlock/ts-stream.lisp
+100
-84
100 additions, 84 deletions
hemlock/ts-stream.lisp
with
100 additions
and
84 deletions
hemlock/ts-stream.lisp
+
100
−
84
View file @
d9e3e045
...
...
@@ -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
))))))))
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment