Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
  • 2 commits
  • 3 files changed
  • 0 commit comments
  • 1 contributor
Commits on Jan 18, 2012
Anton Kovalenko Less consing for restarts.
Reduced consing in restart-bind and friends, in the spirit of the
original handler-bind tricks.

* src/code/defboot.lisp (with-condition-restarts): make use of dx-let
(restart-bind): use dx-let for restart clusters; turn lambda forms
into dx-flettable local functions.

* src/code/target-error.lisp: declaim make-restart constructor inline
to make stack-allocation of restarts possible (CLHS allows
dynamic-extent for restarts).
fb55584
Commits on Jan 21, 2012
Anton Kovalenko Ensure process exit-code actuality when it's examined.
Call GET-PROCESS-STATUS-CHANGES if an exit code is requested for
process that isn't known to complete yet (exit-code field is NIL). It
should guarantee that process-exit-code returns a number, not NIL,
after PROCESS-WAIT on a process returned.
2ba0e78
62 src/code/defboot.lisp
View
@@ -415,12 +415,12 @@ evaluated as a PROGN."
This allows FIND-RESTART, etc., to recognize restarts that are not related
to the error currently being debugged. See also RESTART-CASE."
(let ((n-cond (gensym)))
- `(let ((*condition-restarts*
- (cons (let ((,n-cond ,condition-form))
- (cons ,n-cond
- (append ,restarts-form
- (cdr (assoc ,n-cond *condition-restarts*)))))
- *condition-restarts*)))
+ `(dx-let ((*condition-restarts*
+ (cons (let ((,n-cond ,condition-form))
+ (cons ,n-cond
+ (append ,restarts-form
+ (cdr (assoc ,n-cond *condition-restarts*)))))
+ *condition-restarts*)))
,@body)))
(defmacro-mundanely restart-bind (bindings &body forms)
@@ -428,22 +428,42 @@ evaluated as a PROGN."
"Executes forms in a dynamic context where the given restart bindings are
in effect. Users probably want to use RESTART-CASE. When clauses contain
the same restart name, FIND-RESTART will find the first such clause."
- `(let ((*restart-clusters*
- (cons (list
- ,@(mapcar (lambda (binding)
- (unless (or (car binding)
- (member :report-function
- binding
- :test #'eq))
- (warn "Unnamed restart does not have a ~
+ (let (dx-fun)
+ (setf bindings
+ (flet ((dxify (thing)
+ (typecase thing
+ ((cons (eql lambda))
+ (setf thing `(function ,thing))))
+ (typecase thing
+ ((cons (eql function)
+ (cons
+ (cons (eql lambda))))
+ `(function
+ ,(caar (push (list* (gensym "LAMBDA")
+ (rest (second thing)))
+ dx-fun))))
+ (t thing))))
+ (mapcar (lambda (binding)
+ (cons (first binding)
+ (mapcar #'dxify (rest binding))))
+ bindings)))
+ `(dx-flet ,dx-fun
+ (dx-let ((*restart-clusters*
+ (cons (list
+ ,@(mapcar (lambda (binding)
+ (unless (or (car binding)
+ (member :report-function
+ binding
+ :test #'eq))
+ (warn "Unnamed restart does not have a ~
report function: ~S"
- binding))
- `(make-restart :name ',(car binding)
- :function ,(cadr binding)
- ,@(cddr binding)))
- bindings))
- *restart-clusters*)))
- ,@forms))
+ binding))
+ `(make-restart :name ',(car binding)
+ :function ,(cadr binding)
+ ,@(cddr binding)))
+ bindings))
+ *restart-clusters*)))
+ ,@forms))))
;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if
;;; appropriate. Gross, but it's what the book seems to say...
11 src/code/run-program.lisp
View
@@ -158,7 +158,7 @@
(defstruct (process (:copier nil))
pid ; PID of child process
%status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED
- exit-code ; either exit code or signal
+ %exit-code ; either exit code or signal
core-dumped ; T if a core image was dumped
#-win32 pty ; stream to child's pty, or NIL
input ; stream to child's input, or NIL
@@ -172,7 +172,7 @@
(print-unreadable-object (process stream :type t)
(let ((status (process-status process)))
(if (eq :exited status)
- (format stream "~S ~S" status (process-exit-code process))
+ (format stream "~S ~S" status (process-%exit-code process))
(format stream "~S ~S" (process-pid process) status)))
process))
@@ -183,6 +183,13 @@
#+sb-doc
(setf (documentation 'process-pid 'function) "The pid of the child process.")
+(defun process-exit-code (process)
+ #+sb-doc
+ "Return the exit code of PROCESS."
+ (or (process-%exit-code process)
+ (progn (get-processes-status-changes)
+ (process-%exit-code process))))
+
(defun process-status (process)
#+sb-doc
"Return the current status of PROCESS. The result is one of :RUNNING,
1  src/code/target-error.lisp
View
@@ -32,6 +32,7 @@
(defvar *handler-clusters* (initial-handler-clusters))
+(declaim (inline make-restart))
(defstruct (restart (:copier nil) (:predicate nil))
(name (missing-arg) :type symbol :read-only t)
(function (missing-arg) :type function)

No commit comments for this range

Something went wrong with that request. Please try again.