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)))
54