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