Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
cmucl
cmucl
Commits
11639ee6
Commit
11639ee6
authored
Feb 14, 1992
by
wlott
Browse files
Merged new-alien changes onto trunk.
parent
b6e61091
Changes
40
Expand all
Hide whitespace changes
Inline
Side-by-side
code/alieneval.lisp
View file @
11639ee6
This diff is collapsed.
Click to expand it.
code/c-call.lisp
View file @
11639ee6
This diff is collapsed.
Click to expand it.
code/debug-int.lisp
View file @
11639ee6
...
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.3
5
1992/0
1
/14
15:07:31 ram
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.3
6
1992/0
2
/14
23:44:21 wlott
Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -853,20 +853,13 @@
;;;
(
defsetf
kernel:stack-ref
kernel:%set-stack-ref
)
(
ext:def-c-variable
"control_stack"
system:system-area-pointer
)
(
proclaim
'
(
inline
cstack-pointer-valid-p
))
(
defun
cstack-pointer-valid-p
(
x
)
(
declare
(
type
system:system-area-pointer
x
))
(
and
(
system:pointer<
x
(
kernel:current-sp
))
(
not
(
system:pointer<
x
(
system:alien-access
(
system:alien-value
control_stack
))))))
(
ext:def-c-array
interrupt-array
mach:*sigcontext
4096
)
(
ext:def-c-variable
"lisp_interrupt_contexts"
interrupt-array
)
(
and
(
system:sap<
x
(
kernel:current-sp
))
(
system:sap<=
(
alien:alien-sap
(
alien:extern-alien
"control_stack"
(
*
t
)))
x
)))
;;; TOP-FRAME -- Public.
;;;
...
...
@@ -1055,55 +1048,45 @@
(
defun
find-escaped-frame
(
frame-pointer
)
(
declare
(
type
system:system-area-pointer
frame-pointer
))
(
dotimes
(
index
lisp::*free-interrupt-context-index*
(
values
nil
0
nil
))
(
system:alien-bind
((
scp
(
interrupt-array-ref
(
system:alien-value
lisp_interrupt_contexts
)
index
)
(
system:alien
mach:sigcontext
#.
(
ext:c-sizeof
'mach:sigcontext
))
t
)
(
sc
(
mach:indirect-*sigcontext
scp
)
mach:sigcontext
t
)
(
regs
(
mach:sigcontext-regs
(
system:alien-value
sc
))
mach:int-array
t
))
(
when
(
=
(
system:sap-int
frame-pointer
)
(
system:alien-access
(
mach:int-array-ref
regs
vm::cfp-offset
)))
(
system:without-gcing
(
let
((
code
(
code-object-from-bits
(
system:alien-access
(
mach:int-array-ref
regs
vm::code-offset
)))))
(
when
(
symbolp
code
)
(
return
(
values
code
0
(
system:alien-value
sc
))))
(
let*
((
code-header-len
(
*
(
kernel:get-header-data
code
)
vm:word-bytes
))
(
pc-offset
(
-
(
system:sap-int
(
system:alien-access
(
mach:sigcontext-pc
(
system:alien-value
sc
))))
(
-
(
kernel:get-lisp-obj-address
code
)
vm:other-pointer-type
)
code-header-len
)))
;; Check to see if we were executing in a branch delay slot.
#+
pmax
; pmax only
(
when
(
logbitp
31
(
system:alien-access
(
mach:sigcontext-cause
(
system:alien-value
sc
))))
(
incf
pc-offset
vm:word-bytes
))
(
unless
(
<=
0
pc-offset
(
*
(
ext:truly-the
lisp::index
(
system:%primitive
c::code-code-size
code
))
vm:word-bytes
))
;; We were in an assembly routine. Therefore, use the LRA as
;; the pc.
(
setf
pc-offset
(
-
(
escape-register
(
system:alien-value
sc
)
vm::lra-offset
)
(
kernel:get-lisp-obj-address
code
)
(
alien:with-alien
((
lisp-interrupt-contexts
(
array
(
*
unix:sigcontext
)
nil
)
:extern
))
(
let
((
scp
(
alien:deref
lisp-interrupt-contexts
index
)))
(
when
(
=
(
system:sap-int
frame-pointer
)
(
vm:sigcontext-register
scp
vm::cfp-offset
))
(
system:without-gcing
(
let
((
code
(
code-object-from-bits
(
vm:sigcontext-register
scp
vm::code-offset
))))
(
when
(
symbolp
code
)
(
return
(
values
code
0
scp
)))
(
let*
((
code-header-len
(
*
(
kernel:get-header-data
code
)
vm:word-bytes
))
(
pc-offset
(
-
(
system:sap-int
(
alien:slot
scp
'unix:sc-pc
))
(
-
(
kernel:get-lisp-obj-address
code
)
vm:other-pointer-type
)
code-header-len
)))
(
return
(
if
(
eq
(
kernel:code-debug-info
code
)
:bogus-lra
)
(
let
((
real-lra
(
kernel:code-header-ref
code
real-lra-slot
)))
(
values
(
kernel:lra-code-header
real-lra
)
(
kernel:get-header-data
real-lra
)
nil
))
(
values
code
pc-offset
(
system:alien-value
sc
)))))))))))
;; Check to see if we were executing in a branch delay slot.
#+
pmax
; pmax only
(
when
(
logbitp
31
(
alien:slot
scp
'mips::sc-cause
))
(
incf
pc-offset
vm:word-bytes
))
(
unless
(
<=
0
pc-offset
(
*
(
kernel:code-header-ref
code
vm:code-code-size-slot
)
vm:word-bytes
))
;; We were in an assembly routine. Therefore, use the LRA as
;; the pc.
(
setf
pc-offset
(
-
(
vm:sigcontext-register
scp
vm::lra-offset
)
(
kernel:get-lisp-obj-address
code
)
code-header-len
)))
(
return
(
if
(
eq
(
kernel:code-debug-info
code
)
:bogus-lra
)
(
let
((
real-lra
(
kernel:code-header-ref
code
real-lra-slot
)))
(
values
(
kernel:lra-code-header
real-lra
)
(
kernel:get-header-data
real-lra
)
nil
))
(
values
code
pc-offset
scp
)))))))))))
;;; CODE-OBJECT-FROM-BITS -- internal.
;;;
...
...
@@ -1131,55 +1114,6 @@
;;; Frame utilities.
;;;
;;; ESCAPE-REGISTER -- Internal.
;;;
;;; An escape register saves the value of a register for a frame that someone
;;; interrupts.
;;;
(
defun
escape-register
(
scp
index
)
(
system:alien-bind
((
sc
scp
mach:sigcontext
t
)
(
regs
(
mach:sigcontext-regs
(
system:alien-value
sc
))
mach:int-array
t
))
(
system:alien-access
(
mach:int-array-ref
(
system:alien-value
regs
)
index
))))
(
defun
%set-escape-register
(
scp
index
new
)
(
system:alien-bind
((
sc
scp
mach:sigcontext
t
)
(
regs
(
mach:sigcontext-regs
(
system:alien-value
sc
))
mach:int-array
t
))
(
setf
(
system:alien-access
(
mach:int-array-ref
(
system:alien-value
regs
)
index
))
new
)))
(
defsetf
escape-register
%set-escape-register
)
;;; ESCAPE-FLOAT-REGISTER -- Internal
;;;
;;; Like ESCAPE-REGISTER, but returns the value of a float register. Format
;;; is the type of float to return.
;;;
(
defun
escape-float-register
(
scp
index
format
)
(
system:alien-bind
((
sc
scp
mach:sigcontext
t
)
(
fpregs
(
mach:sigcontext-fpregs
(
system:alien-value
sc
))
mach:int-array
t
))
(
let
((
sap
(
system:alien-sap
fpregs
)))
(
ecase
format
(
single-float
(
system:sap-ref-single
sap
index
))
(
double-float
(
system:sap-ref-double
sap
index
))))))
;;;
(
defun
%set-escape-float-register
(
scp
index
format
new-value
)
(
system:alien-bind
((
sc
scp
mach:sigcontext
t
)
(
fpregs
(
mach:sigcontext-fpregs
(
system:alien-value
sc
))
mach:int-array
t
))
(
let
((
sap
(
system:alien-sap
fpregs
)))
(
ecase
format
(
single-float
(
setf
(
system:sap-ref-single
sap
index
)
new-value
))
(
double-float
(
setf
(
system:sap-ref-double
sap
index
)
new-value
))))))
;;;
(
defsetf
escape-float-register
%set-escape-float-register
)
;;; DEBUG-FUNCTION-FROM-PC -- Internal.
;;;
;;; This returns a compiled-debug-function for code and pc. We fetch the
...
...
@@ -2451,21 +2385,23 @@
(
defun
sub-access-debug-var-slot
(
fp
sc-offset
&optional
escaped
)
(
macrolet
((
with-escaped-value
((
var
)
&body
forms
)
`
(
if
escaped
(
let
((
,
var
(
escape
-register
(
let
((
,
var
(
vm:sigcontext
-register
escaped
(
c::sc-offset-offset
sc-offset
))))
,@
forms
)
:invalid-value-for-unescaped-register-storage
))
(
escaped-float-value
(
format
)
`
(
if
escaped
(
escape-float-register
escaped
(
c::sc-offset-offset
sc-offset
)
',format
)
(
vm:sigcontext-float-register
escaped
(
c::sc-offset-offset
sc-offset
)
',format
)
:invalid-value-for-unescaped-register-storage
))
(
with-nfp
((
var
)
&body
body
)
`
(
let
((
,
var
(
if
escaped
(
system:int-sap
(
escape-register
escaped
vm::nfp-offset
))
(
vm:sigcontext-register
escaped
vm::nfp-offset
))
(
system:sap-ref-sap
fp
vm::nfp-save-offset
))))
,@
body
)))
(
ecase
(
c::sc-offset-scn
sc-offset
)
...
...
@@ -2571,13 +2507,14 @@
(
defun
sub-set-debug-var-slot
(
fp
sc-offset
value
&optional
escaped
)
(
macrolet
((
set-escaped-value
(
val
)
`
(
if
escaped
(
setf
(
escape-register
escaped
(
c::sc-offset-offset
sc-offset
))
(
setf
(
vm:sigcontext-register
escaped
(
c::sc-offset-offset
sc-offset
))
,
val
)
value
))
(
set-escaped-float-value
(
format
val
)
`
(
if
escaped
(
setf
(
escape
-float-register
(
setf
(
vm:sigcontext
-float-register
escaped
(
c::sc-offset-offset
sc-offset
)
',format
)
...
...
@@ -2586,7 +2523,8 @@
(
with-nfp
((
var
)
&body
body
)
`
(
let
((
,
var
(
if
escaped
(
system:int-sap
(
escape-register
escaped
vm::nfp-offset
))
(
vm:sigcontext-register
escaped
vm::nfp-offset
))
(
system:sap-ref-sap
fp
vm::nfp-save-offset
))))
,@
body
)))
(
ecase
(
c::sc-offset-scn
sc-offset
)
...
...
@@ -3271,9 +3209,9 @@
;;; the overwritten bits. You must call this in a context in which GC is
;;; disabled, so Lisp doesn't move objects around that C is pointing to.
;;;
(
ext:def-c
-routine
"breakpoint_install"
(
ext
:unsigned-long
)
(
code-obj
ext
:unsigned-long
)
(
pc-offset
ext
:int
))
(
alien:def-alien
-routine
"breakpoint_install"
c-call
:unsigned-long
(
code-obj
c-call
:unsigned-long
)
(
pc-offset
c-call
:int
))
;;; BREAKPOINT_REMOVE -- Internal.
;;;
...
...
@@ -3281,17 +3219,17 @@
;;; You must call this in a context in which GC is disabled, so Lisp doesn't
;;; move objects around that C is pointing to.
;;;
(
ext:def-c
-routine
"breakpoint_remove"
(
ext
:void
)
(
code-obj
ext
:unsigned-long
)
(
pc-offset
ext
:int
)
(
old-inst
ext
:unsigned-long
))
(
alien:def-alien
-routine
"breakpoint_remove"
c-call
:void
(
code-obj
c-call
:unsigned-long
)
(
pc-offset
c-call
:int
)
(
old-inst
c-call
:unsigned-long
))
;;; BREAKPOINT_AFTER_OFFSET -- Internal.
;;;
;;; This returns the offset of the next instruction following the break that
;;; generated the signal context we supply as an argument to this routine.
;;;
(
ext:def-c
-routine
"breakpoint_after_offset"
(
ext
:int
)
(
alien:def-alien
-routine
"breakpoint_after_offset"
c-call
:int
(
scp
system:system-area-pointer
))
;;;
...
...
@@ -3386,7 +3324,7 @@
;; Set the sigmask, to keep the system running until we can
;; remove the after breakpoints and re-install the user breakpoints.
(
setf
(
breakpoint-data-sigmask
data
)
(
mach
:unix-sigblock
(
mach
:sigmask
:sigint
:sigquit
:sigtstp
))))))
(
unix
:unix-sigblock
(
unix
:sigmask
:sigint
:sigquit
:sigtstp
))))))
(
defun
handle-after-breakpoint
(
after
breakpoints
data
offset
component
)
(
let
((
previous-data
(
after-breakpoint-previous-data
after
)))
...
...
@@ -3418,7 +3356,7 @@
(
breakpoint-data-component
previous-data
))
(
breakpoint-data-offset
previous-data
)))
;; Restore sigmask that we saved before executing previous's inst.
(
mach
:unix-sigsetmask
(
breakpoint-data-sigmask
previous-data
))))
(
unix
:unix-sigsetmask
(
breakpoint-data-sigmask
previous-data
))))
(
defun
invoke-breakpoint-hooks
(
breakpoints
component
offset
after
)
(
let*
((
debug-fun
(
debug-function-from-pc
component
offset
))
...
...
@@ -3469,41 +3407,36 @@
;;;
(
defun
handle-function-end-breakpoint
(
breakpoints
data
signal-context
)
(
delete-breakpoint-data
data
)
(
system:alien-bind
((
sc
(
system:make-alien
'mach:sigcontext
#.
(
ext:c-sizeof
'mach:sigcontext
)
signal-context
)
mach:sigcontext
t
))
(
let*
((
frame
(
do
((
cfp
(
escape-register
sc
vm::cfp-offset
))
(
f
(
top-frame
)
(
frame-down
f
)))
((
=
cfp
(
system:sap-int
(
frame-pointer
f
)))
f
)
(
declare
(
type
(
unsigned-byte
#.
vm:word-bits
)
cfp
))))
(
component
(
breakpoint-data-component
data
))
(
cookie
(
gethash
component
*function-end-cookies*
)))
(
remhash
component
*function-end-cookies*
)
(
dolist
(
bpt
breakpoints
)
(
funcall
(
breakpoint-hook-function
bpt
)
frame
bpt
(
get-function-end-breakpoint-values
(
system:alien-value
sc
))
cookie
)))))
(
defun
get-function-end-breakpoint-values
(
sc
)
(
system:alien-bind
((
sc
sc
mach:sigcontext
t
))
(
let
((
ocfp
(
system:int-sap
(
escape-register
sc
vm::ocfp-offset
)))
(
nargs
(
kernel:make-lisp-obj
(
escape-register
sc
vm::nargs-offset
)))
(
reg-arg-offsets
vm::register-arg-offsets
)
(
results
nil
))
(
system:without-gcing
(
dotimes
(
arg-num
nargs
)
(
push
(
if
reg-arg-offsets
(
kernel:make-lisp-obj
(
escape-register
sc
(
pop
reg-arg-offsets
)))
(
kernel:stack-ref
ocfp
arg-num
))
results
)))
(
nreverse
results
))))
(
let*
((
scp
(
alien:sap-alien
signal-context
(
*
unix:sigcontext
)))
(
frame
(
do
((
cfp
(
vm:sigcontext-register
scp
vm::cfp-offset
))
(
f
(
top-frame
)
(
frame-down
f
)))
((
=
cfp
(
system:sap-int
(
frame-pointer
f
)))
f
)
(
declare
(
type
(
unsigned-byte
#.
vm:word-bits
)
cfp
))))
(
component
(
breakpoint-data-component
data
))
(
cookie
(
gethash
component
*function-end-cookies*
)))
(
remhash
component
*function-end-cookies*
)
(
dolist
(
bpt
breakpoints
)
(
funcall
(
breakpoint-hook-function
bpt
)
frame
bpt
(
get-function-end-breakpoint-values
scp
)
cookie
))))
(
defun
get-function-end-breakpoint-values
(
scp
)
(
let
((
ocfp
(
system:int-sap
(
escape-register
scp
vm::ocfp-offset
)))
(
nargs
(
kernel:make-lisp-obj
(
escape-register
scp
vm::nargs-offset
)))
(
reg-arg-offsets
vm::register-arg-offsets
)
(
results
nil
))
(
system:without-gcing
(
dotimes
(
arg-num
nargs
)
(
push
(
if
reg-arg-offsets
(
kernel:make-lisp-obj
(
vm:sigcontext-register
scp
(
pop
reg-arg-offsets
)))
(
kernel:stack-ref
ocfp
arg-num
))
results
)))
(
nreverse
results
)))
;;; CALL-BREAKPOINT_AFTER_OFFSET -- Internal.
;;; CAL
<
L-BREAKPOINT_AFTER_OFFSET -- Internal.
;;;
;;; This calls the C routine and massages its return values. Originally the
;;; breakpoint code was designed for the C code to return multiple offsets when
...
...
@@ -3534,18 +3467,12 @@
are returned: the bogus LRA object, the code component it is part of, and the
PC offset for the trap instruction."
(
system:without-gcing
(
let*
((
src-start
(
ext:truly-the
system:system-area-pointer
(
system:%primitive
c:foreign-symbol-address
"function_end_breakpoint_guts"
)))
(
src-end
(
ext:truly-the
system:system-area-pointer
(
system:%primitive
c:foreign-symbol-address
"function_end_breakpoint_end"
)))
(
trap-loc
(
ext:truly-the
system:system-area-pointer
(
system:%primitive
c:foreign-symbol-address
"function_end_breakpoint_trap"
)))
(
let*
((
src-start
(
system:foreign-symbol-address
"function_end_breakpoint_guts"
))
(
src-end
(
system:foreign-symbol-address
"function_end_breakpoint_end"
))
(
trap-loc
(
system:foreign-symbol-address
"function_end_breakpoint_trap"
))
(
length
(
system:sap-
src-end
src-start
))
(
code-object
(
system:%primitive
c:allocate-code-object
(
1+
bogus-lra-constants
)
...
...
code/debug.lisp
View file @
11639ee6
...
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.2
5
199
1/12/16 09:27:25
wlott Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.2
6
199
2/02/14 23:44:34
wlott Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -258,7 +258,7 @@
(t
(when number
(format t "
~&~S:
" (di:frame-number frame)))
(mach:unix-sigsetmask 0
)
(print-frame-call-1 frame))
)
(when (>= verbosity 2)
(let ((loc (di:frame-code-location frame)))
(*debug-abort* (find-restart 'abort))
...
...
code/exports.lisp
View file @
11639ee6
This diff is collapsed.
Click to expand it.
code/fd-stream.lisp
View file @
11639ee6
...
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.1
8
199
1/12/16 12
:4
8
:45 wlott Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.1
9
199
2/02/14 23
:4
4
:45 wlott Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -138,15 +138,15 @@
(
declare
(
type
index
start
end
length
))
(
multiple-value-bind
(
count
errno
)
(
mach
:unix-write
(
fd-stream-fd
stream
)
(
unix
:unix-write
(
fd-stream-fd
stream
)
base
start
length
)
(
cond
((
not
count
)
(
if
(
=
errno
mach
:ewouldblock
)
(
if
(
=
errno
unix
:ewouldblock
)
(
error
"Write would have blocked, but SERVER told us to go."
)
(
error
"While writing ~S: ~A"
stream
(
mach
:get-unix-error-msg
errno
))))
stream
(
unix
:get-unix-error-msg
errno
))))
((
eql
count
length
)
; Hot damn, it workded.
(
when
reuse-sap
(
push
base
*available-buffers*
)))
...
...
@@ -199,12 +199,12 @@
(
let
((
length
(
-
end
start
)))
(
multiple-value-bind
(
count
errno
)
(
mach
:unix-write
(
fd-stream-fd
stream
)
base
start
length
)
(
unix
:unix-write
(
fd-stream-fd
stream
)
base
start
length
)
(
cond
((
not
count
)
(
if
(
=
errno
mach
:ewouldblock
)
(
if
(
=
errno
unix
:ewouldblock
)
(
output-later
stream
base
start
end
reuse-sap
)
(
error
"While writing ~S: ~A"
stream
(
mach
:get-unix-error-msg
errno
))))
stream
(
unix
:get-unix-error-msg
errno
))))
((
not
(
eql
count
length
))
(
output-later
stream
base
(
+
start
count
)
end
reuse-sap
)))))))
...
...
@@ -450,7 +450,7 @@
#+
serve-event
(
multiple-value-bind
(
count
errno
)
(
mach
:unix-select
(
1+
fd
)
(
ash
1
fd
)
0
0
0
)
(
unix
:unix-select
(
1+
fd
)
(
ash
1
fd
)
0
0
0
)
(
case
count
(
1
)
(
0
...
...
@@ -460,14 +460,14 @@
(
t
(
error
"Problem checking to see if ~S is readable: ~A"
stream
(
mach
:get-unix-error-msg
errno
)))))
(
unix
:get-unix-error-msg
errno
)))))
(
multiple-value-bind
(
count
errno
)
(
mach
:unix-read
fd
(
unix
:unix-read
fd
(
system:int-sap
(
+
(
system:sap-int
ibuf-sap
)
tail
))
(
-
buflen
tail
))
(
cond
((
null
count
)
(
if
#+
serve-event
(
eql
errno
mach
:ewouldblock
)
(
if
#+
serve-event
(
eql
errno
unix
:ewouldblock
)
#-
serve-event
nil
(
progn
(
unless
(
system:wait-until-fd-usable
...
...
@@ -476,7 +476,7 @@
(
do-input
stream
))
(
error
"Error reading ~S: ~A"
stream
(
mach
:get-unix-error-msg
errno
))))
(
unix
:get-unix-error-msg
errno
))))
((
zerop
count
)
(
setf
(
fd-stream-listen
stream
)
:eof
)
(
throw
'eof-input-catcher
nil
))
...
...
@@ -774,7 +774,7 @@ non-server method is also significantly more efficient for large reads.
(
loop
(
multiple-value-bind
(
count
err
)
(
mach
:unix-read
(
fd-stream-fd
stream
)
(
unix
:unix-read
(
fd-stream-fd
stream
)
(
sap+
(
if
(
typep
buffer
'system-area-pointer
)
buffer
(
vector-sap
buffer
))
...
...
@@ -783,7 +783,7 @@ non-server method is also significantly more efficient for large reads.
(
declare
(
type
(
or
index
null
)
count
))
(
unless
count
(
error
"Error reading ~S: ~A"
stream
(
mach
:get-unix-error-msg
err
)))
(
unix
:get-unix-error-msg
err
)))
(
when
(
zerop
count
)
(
if
eof-error-p
(
error
"Unexpected eof on ~S."
stream
)
...
...
@@ -795,11 +795,11 @@ non-server method is also significantly more efficient for large reads.
(
loop
(
multiple-value-bind
(
count
err
)
(
mach
:unix-read
(
fd-stream-fd
stream
)
sap
len
)
(
unix
:unix-read
(
fd-stream-fd
stream
)
sap
len
)
(
declare
(
type
(
or
index
null
)
count
))
(
unless
count
(
error
"Error reading ~S: ~A"
stream
(
mach
:get-unix-error-msg
err
)))
(
unix
:get-unix-error-msg
err
)))
(
incf
(
fd-stream-ibuf-tail
stream
)
count
)
(
when
(
zerop
count
)
(
if
eof-error-p
...
...
@@ -933,7 +933,7 @@ non-server method is also significantly more efficient for large reads.
(
fd-stream-ibuf-tail
stream
)))
(
fd-stream-listen
stream
)
(
setf
(
fd-stream-listen
stream
)
(
eql
(
mach
:unix-select
(
1+
(
fd-stream-fd
stream
))
(
eql
(
unix
:unix-select
(
1+
(
fd-stream-fd
stream
))
(
ash
1
(
fd-stream-fd
stream
))
0
0
...
...
@@ -954,38 +954,38 @@ non-server method is also significantly more efficient for large reads.
;; Have an handle on the original, just revert.
(
multiple-value-bind
(
okay
err
)
(
mach
:unix-rename
(
fd-stream-original
stream
)
(
unix
:unix-rename
(
fd-stream-original
stream
)
(
fd-stream-file
stream
))
(
unless
okay
(
cerror
"Go on as if nothing bad happened."
"Could not restore ~S to it's original contents: ~A"
(
fd-stream-file
stream
)
(
mach
:get-unix-error-msg
err
))))
(
unix
:get-unix-error-msg
err
))))
;; Can't restore the orignal, so nuke that puppy.
(
multiple-value-bind
(
okay
err
)
(
mach
:unix-unlink
(
fd-stream-file
stream
))
(
unix
:unix-unlink
(
fd-stream-file
stream
))
(
unless
okay
(
cerror
"Go on as if nothing bad happened."
"Could not remove ~S: ~A"
(
fd-stream-file
stream
)
(
mach
:get-unix-error-msg
err
)))))))
(
unix
:get-unix-error-msg
err
)))))))
(
t
(
fd-stream-misc-routine
stream
:finish-output
)
(
when
(
and
(
fd-stream-original
stream
)
(
fd-stream-delete-original
stream
))
(
multiple-value-bind
(
okay
err
)
(
mach
:unix-unlink
(
fd-stream-original
stream
))
(
unix
:unix-unlink
(
fd-stream-original
stream
))
(
unless
okay
(
cerror
"Go on as if nothing bad happened."
"Could not delete ~S during close of ~S: ~A"
(
fd-stream-original
stream
)
stream
(
mach
:get-unix-error-msg
err
)))))))
(
unix
:get-unix-error-msg
err
)))))))
(
when
(
fboundp
'cancel-finalization
)
(
cancel-finalization
stream
))
(
mach
:unix-close
(
fd-stream-fd
stream
))
(
unix
:unix-close
(
fd-stream-fd
stream
))
(
when
(
fd-stream-obuf-sap
stream
)
(
push
(
fd-stream-obuf-sap
stream
)
*available-buffers*
)
(
setf
(
fd-stream-obuf-sap
stream
)
nil
))
...
...
@@ -997,7 +997,7 @@ non-server method is also significantly more efficient for large reads.
(
setf
(
fd-stream-ibuf-head
stream
)
0
)
(
setf
(
fd-stream-ibuf-tail
stream
)
0
)
(
loop
(
let
((
count
(
mach
:unix-select
(
1+
(
fd-stream-fd
stream
))
(
let
((
count
(
unix
:unix-select
(
1+
(
fd-stream-fd
stream
))
(
ash
1
(
fd-stream-fd
stream
))
0
0
0
)))
(
cond
((
eql
count
1
)
...
...
@@ -1024,13 +1024,13 @@ non-server method is also significantly more efficient for large reads.
(
multiple-value-bind
(
okay
dev
ino
mode
nlink
uid
gid
rdev
size
atime
mtime
ctime
blksize
blocks
)
(
mach
:unix-fstat
(
fd-stream-fd
stream
))
(
unix
:unix-fstat
(
fd-stream-fd
stream
))
(
declare
(
ignore
ino
nlink
uid
gid
rdev
atime
mtime
ctime
blksize
blocks
))
(
unless
okay
(
error
"Error fstating ~S: ~A"
stream
(
mach
:get-unix-error-msg
dev
)))
(
unix
:get-unix-error-msg
dev
)))
(
if
(
zerop
mode
)
nil
(
truncate
size
(
fd-stream-element-size
stream
)))))
...
...
@@ -1050,7 +1050,7 @@ non-server method is also significantly more efficient for large reads.
;; file.
(
multiple-value-bind
(
posn
errno
)
(
mach
:unix-lseek
(
fd-stream-fd
stream
)
0
mach
:l_incr
)
(
unix
:unix-lseek
(
fd-stream-fd
stream
)
0
unix
:l_incr
)
(
declare
(
type
(
or
index
null
)
posn
))
(
cond
((
fixnump
posn
)
;; Adjust for buffered output:
...
...
@@ -1073,13 +1073,13 @@ non-server method is also significantly more efficient for large reads.
(
decf
posn
))
;; Divide bytes by element size.
(
truncate
posn
(
fd-stream-element-size
stream
)))
((
eq
errno
mach
:espipe
)
((
eq
errno
unix
:espipe
)
nil
)
(
t
(
system:with-interrupts
(
error
"Error lseek'ing ~S: ~A"
stream
(
mach
:get-unix-error-msg
errno
)))))))
(
unix
:get-unix-error-msg
errno
)))))))
(
let
(
offset
origin
)