losp/muerte/restarts.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2001, 2003-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway.
   5 ;;;;
   6 ;;;;    For distribution policy, see the accompanying file COPYING.
   7 ;;;;
   8 ;;;; Filename:      restarts.lisp
   9 ;;;; Description:
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Tue Oct 28 09:27:13 2003
  12 ;;;;
  13 ;;;; $Id: restarts.lisp,v 1.6 2005/05/05 20:51:51 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17 (require :muerte/basic-macros)
  18 (provide :muerte/restarts)
  19
  20 (in-package muerte)
  21
  22 (defmacro restart-bind (restart-specs &body body)
  23   (if (null restart-specs)
  24       `(progn ,@body)
  25     (let ((restart-spec (car restart-specs))
  26           (rest-specs (cdr restart-specs)))
  27       (destructuring-bind (name function &key interactive-function
  28                                               report-function
  29                                               test-function)
  30           restart-spec
  31         `(with-basic-restart (,name ,function ,interactive-function
  32                                     ,test-function ,report-function)
  33            (restart-bind ,rest-specs ,@body))))))
  34
  35 (defun dynamic-context->basic-restart (context)
  36   (assert (< (%run-time-context-slot nil 'stack-bottom)
  37              context
  38              (%run-time-context-slot nil 'stack-top)))
  39   (assert (eq (load-global-constant restart-tag)
  40               (stack-frame-ref nil context 1 :lisp)))
  41   (let ((x (- (%run-time-context-slot nil 'stack-top) context)))
  42     (assert (below x #x1000000))
  43     (with-inline-assembly (:returns :eax)
  44       (:compile-form (:result-mode :eax) x)
  45       (:shll 6 :eax)
  46       (:movb #.(movitz::tag :basic-restart) :al))))
  47
  48 (defun basic-restart->dynamic-context (basic-restart)
  49   (check-type basic-restart basic-restart)
  50   (with-inline-assembly (:returns :eax)
  51     (:compile-form (:result-mode :eax) basic-restart)
  52     (:movb 0 :al)
  53     (:locally (:movl (:edi (:edi-offset stack-top)) :ecx))
  54     (:shrl 6 :eax)
  55     (:negl :eax)
  56     (:leal (:eax :ecx) :eax)))
  57
  58 (define-simple-typep (basic-restart basic-restart-p) (x)
  59   (with-inline-assembly (:returns :boolean-zf=1)
  60     (:compile-form (:result-mode :eax) x)
  61     (:cmpb #.(movitz::tag :basic-restart) :al)
  62     (:jne 'fail)
  63     (:shrl 6 :eax)
  64     (:locally (:movl (:edi (:edi-offset stack-top)) :ecx))
  65     (:locally (:movl (:edi (:edi-offset dynamic-env)) :ebx))
  66 ;;    (:shll 2 :ebx)
  67     (:subl :ebx :ecx)
  68     (:cmpl :eax :ecx)
  69     (:jna 'fail)
  70     (:globally (:movl (:edi (:edi-offset restart-tag)) :ebx))
  71     (:negl :eax)
  72     (:locally (:movl (:edi (:edi-offset stack-top)) :ecx))
  73     (:cmpl :ebx (:eax :ecx 4))
  74    fail))
  75
  76 (defun restart-name (restart)
  77   (etypecase restart
  78     (basic-restart
  79      (stack-frame-ref nil (basic-restart->dynamic-context restart)
  80                       -1 :lisp))))
  81
  82 (defun restart-function (restart)
  83   (etypecase restart
  84     (basic-restart
  85      (stack-frame-ref nil (basic-restart->dynamic-context restart)
  86                       -2 :lisp))))
  87
  88 (defun restart-interactive-function (restart)
  89   (etypecase restart
  90     (basic-restart
  91      (stack-frame-ref nil (basic-restart->dynamic-context restart)
  92                       -3 :lisp))))
  93
  94 (defun restart-test (restart)
  95   (etypecase restart
  96     (basic-restart
  97      (stack-frame-ref nil (basic-restart->dynamic-context restart)
  98                       -4 :lisp))))
  99
 100 (defun restart-format-control (restart)
 101   (etypecase restart
 102     (basic-restart
 103      (stack-frame-ref nil (basic-restart->dynamic-context restart)
 104                       -5 :lisp))))
 105
 106 (defun restart-args (restart)
 107   (etypecase restart
 108     (basic-restart
 109      (stack-frame-ref nil (basic-restart->dynamic-context restart)
 110                       -6 :lisp))))
 111
 112 (defun invoke-restart (restart-designator &rest arguments)
 113   (declare (dynamic-extent arguments))
 114   (let ((restart (find-restart restart-designator)))
 115     (typecase restart
 116       (basic-restart
 117        (let ((function (restart-function restart)))
 118          (etypecase function
 119            (function
 120             (apply function arguments))
 121            (symbol
 122             (exact-throw (basic-restart->dynamic-context restart)
 123                          (ecase function
 124                            ((with-simple-restart)
 125                             (values nil t))))))))
 126       (t (error 'control-error
 127                 :format-control "Can't invoke invalid restart ~S."
 128                 :format-arguments (list restart-designator))))))
 129
 130 (defun invoke-restart-interactively (restart-designator)
 131   (let ((restart (find-restart restart-designator)))
 132     (typecase restart
 133       (basic-restart
 134        (let ((interactive-function (restart-interactive-function restart)))
 135          (etypecase interactive-function
 136            (function
 137             (apply 'invoke-restart restart (funcall interactive-function)))
 138            (null
 139             (invoke-restart restart)))))
 140       (t (error 'control-error
 141                 :format-control "Can't interactively invoke invalid restart ~S."
 142                 :format-arguments (list restart-designator))))))
 143
 144 (defun find-restart-from-context (specifier context &optional condition)
 145   (declare (ignore condition))
 146   (etypecase specifier
 147     (basic-restart
 148      specifier)
 149     (symbol
 150      (with-each-dynamic-context (context)
 151        ((:basic-restart context name)
 152         (when (eq name specifier)
 153           (return (dynamic-context->basic-restart context))))))))
 154
 155 (defun find-restart (specifier &optional condition)
 156   (find-restart-from-context specifier (current-dynamic-context) condition))
 157
 158 (defun find-restart-by-index (index &optional (context (current-dynamic-context)))
 159   (let ((counter 0))
 160     (with-each-dynamic-context (context)
 161       ((:basic-restart context)
 162        (when (= counter index)
 163          (return (dynamic-context->basic-restart context)))
 164        (incf counter)))))
 165
 166 (defun compute-restarts (&optional condition)
 167   (declare (ignore condition))
 168   (let (computed-restarts)
 169     (with-each-dynamic-context ()
 170       ((:basic-restart context name)
 171        (declare (ignore name))
 172        (push (dynamic-context->basic-restart context)
 173              computed-restarts)))
 174     (nreverse computed-restarts)))
 175
 176 (defun map-active-restarts (&optional function (context (current-dynamic-context)))
 177   "Map function over each active restart, ordered by the innermost one first.
 178    The function is called with two arguments: the restart and the index.
 179    Returns the number of restarts."
 180   (let ((index 0))
 181     (with-each-dynamic-context (context)
 182       ((:basic-restart context)
 183        (when function
 184          (funcall function (dynamic-context->basic-restart context) index))
 185        (incf index)))
 186     index))
 187
 188 (defmethod print-object ((restart restart) stream)
 189   (cond
 190    (*print-escape*
 191     (print-unreadable-object (restart stream :type nil :identity t)
 192       (format stream "Restart ~W" (restart-name restart))))
 193    ((not *print-escape*)
 194     (etypecase restart
 195       (basic-restart
 196        (if (not (restart-format-control restart))
 197            (write (restart-name restart) :stream stream)
 198          (apply 'format stream
 199                 (restart-format-control restart)
 200                 (restart-args restart)))))))
 201   restart)
 202
 203 ;;;;
 204
 205 (defun abort (&optional condition)
 206   (let ((r (find-restart 'abort condition)))
 207     (when r (invoke-restart r))
 208     (formatted-error 'control-error "Abort failed.")))
 209
 210 (defun continue ()
 211   (let ((r (find-restart 'continue)))
 212     (when r
 213       (invoke-restart r))))
 214
 215 (defun muffle-warning (&optional condition)
 216   (let ((r (find-restart 'muffle-warning condition)))
 217     (when r (invoke-restart r))
 218     (formatted-error 'control-error "Muffle-warning failed.")))
 219