src/safe-recursion.lisp

   1 ;;; safe-recursion.lisp
   2 ;;;
   3 ;;; This is intended as a simple way to allow code to bounce around the (large
   4 ;;; and confusing) Maxima system without having to worry so much about stack
   5 ;;; overflows from unbounded recursion.
   6 ;;;
   7 ;;; An "unsafe recursion" is defined as one that comes back to the same call
   8 ;;; site with an argument that is either equal to or contains one we've seen
   9 ;;; before. In that case, we assume that we're either stuck in a recursive loop
  10 ;;; or we're diverging and we should raise an error.
  11 ;;;
  12 ;;; Obviously, this doesn't catch every sort of unbounded recursion (for
  13 ;;; example, FOO could recurse to itself, incrementing its argument each call),
  14 ;;; but it should catch the silliest examples.
  15
  16 (in-package :maxima)
  17
  18 (define-condition unsafe-recursion (error)
  19   ((name     :initarg :name :reader ur-name)
  20    (existing :initarg :existing :reader ur-existing)
  21    (arg      :initarg :arg :reader ur-arg))
  22   (:report
  23    (lambda (err stream)
  24      (format stream "Unsafe recursion at site ~A. ~
  25                      Known args ~S contain ~S as a subtree"
  26              (ur-name err) (ur-existing err) (ur-arg err)))))
  27
  28 ;;; CALL-WITH-SAFE-RECURSION
  29 ;;;
  30 ;;; Call (FUNCALL THUNK), but record the call on the plist of NAME. FUN may
  31 ;;; recurse through this call site again, but only if the new argument isn't a
  32 ;;; cons containing ARG as a subtree.
  33 ;;;
  34 ;;; If a recursion is spotted, raise an UNSAFE-RECURSION error.
  35 (defun call-with-safe-recursion (name arg thunk)
  36   (let ((known-args (get name 'current-recursion-args)))
  37     (when (find-if (lambda (known)
  38                      (if (consp known)
  39                          (appears-in arg known)
  40                          (equal arg known)))
  41                    known-args)
  42       (error 'unsafe-recursion :name name :existing known-args :arg arg))
  43
  44     (unwind-protect
  45          (progn
  46            (setf (get name 'current-recursion-args)
  47                  (cons arg known-args))
  48            (funcall thunk))
  49       (setf (get name 'current-recursion-args)
  50             (remove arg known-args)))))
  51
  52 (defmacro with-safe-recursion (name arg &body body)
  53   `(call-with-safe-recursion ',name ,arg (lambda () ,@body)))