>From 99b09a87ed1a0f42a45496aa7f38f29624cf82e6 Mon Sep 17 00:00:00 2001
From: Eugene Zhemchugov <jini.zh@gmail.com>
Date: Fri, 9 Jan 2015 20:38:12 +0300
Subject: [PATCH] Fix recurring callbacks (partial)

Use binding instead of assignment for dynamic variables in the callbacks
implementation. This way recursive calls to functions utilizing
callbacks can be performed, however, the current implementation breaks
when a callback is stored in an object.
---
 calculus/numerical-integration.lisp |  5 ++-
 init/body-expand.lisp               | 81 +++++++++++++++++++------------------
 init/defmfun-single.lisp            |  3 +-
 tests/numerical-integration.lisp    | 11 ++++-
 4 files changed, 56 insertions(+), 44 deletions(-)

diff --git a/calculus/numerical-integration.lisp b/calculus/numerical-integration.lisp
index f4c79d9..167aff8 100644
--- a/calculus/numerical-integration.lisp
+++ b/calculus/numerical-integration.lisp
@@ -369,4 +369,7 @@
   'integration-test-f454
   (grid:copy-to (vector 0.0d0 1.0d0 (sqrt 2.0d0) 3.0d0))
   0.0d0 1.0d-3 1000)
- (integration-QAWc 'integration-test-f459 -1.0d0 5.0d0 0.0d0 0.0d0 1.0d-3 1000))
+ (integration-QAWc 'integration-test-f459 -1.0d0 5.0d0 0.0d0 0.0d0 1.0d-3 1000)
+ (integration-QAG (lambda (x)
+                    (integration-QAG (lambda (y) (* (sin x) y)) 0d0 1d0 :gauss41))
+                  0d0 pi :gauss41))
diff --git a/init/body-expand.lisp b/init/body-expand.lisp
index 34e1602..d2db213 100644
--- a/init/body-expand.lisp
+++ b/init/body-expand.lisp
@@ -71,50 +71,53 @@
 		    (callback-remove-arg allocated-return cbinfo 'grid:st-symbol))
 		   outputs
 		   (unless (eq c-return :void)
-		     (list (grid:st-symbol creturn-st))))))
+		     (list (grid:st-symbol creturn-st)))))
+           (specials (first callback-dynamic-variables)))
       (wrap-letlike
        allocated-return
        (mapcar (lambda (d) (wfo-declare d cbinfo))
 	       allocated-return)
        'cffi:with-foreign-objects
-       `(,@(append
-	    (callback-symbol-set
-	     callback-dynamic cbinfo (first callback-dynamic-variables))
-	    before
-	    (when callback-object (callback-set-dynamic callback-object arglist)))
-	 ,@(callback-set-slots
-	    cbinfo callback-dynamic-variables callback-dynamic)
-	 (let ((,(grid:st-symbol creturn-st)
-		 (cffi:foreign-funcall
-		  ,gsl-name
-		  ,@(append
-		     (mappend
-		      (lambda (arg)
-			(list (cond
-				((member (grid:st-symbol arg)
-					 allocated-return)
-				 :pointer)
-				(t (grid:st-type arg)))
-			      (grid:st-symbol arg)))
-		      (mapcar 'grid:st-pointer-generic-pointer
-			      c-arguments))
-		     (list (grid:st-type creturn-st))))))
-	   ,@(case c-return
-	       (:void `((declare (ignore ,(grid:st-symbol creturn-st)))))
-	       (:error-code		; fill in arguments
-		`((check-gsl-status ,(grid:st-symbol creturn-st)
-				    ',(or (defgeneric-method-p name) name)))))
-	   ,@(when (eq (grid:st-type creturn-st) :pointer)
-	       `((check-null-pointer
-		  ,(grid:st-symbol creturn-st)
-		  ,@'('memory-allocation-failure "No memory allocated."))))
-	   ,@after
-	   ,(values-unless-singleton
-	     (defmfun-return
-		 c-return (grid:st-symbol creturn-st) clret
-	       allocated-return
-	       return return-supplied-p
-	       enumeration outputs))))))))
+       `((let ,specials
+           ,(when specials `(declare (special ,@specials)))
+           ,@(append
+              (callback-symbol-set
+               callback-dynamic cbinfo (first callback-dynamic-variables))
+              before
+              (when callback-object (callback-set-dynamic callback-object arglist)))
+           ,@(callback-set-slots
+              cbinfo callback-dynamic-variables callback-dynamic)
+           (let ((,(grid:st-symbol creturn-st)
+                   (cffi:foreign-funcall
+                    ,gsl-name
+                    ,@(append
+                       (mappend
+                        (lambda (arg)
+                          (list (cond
+                                  ((member (grid:st-symbol arg)
+                                           allocated-return)
+                                   :pointer)
+                                  (t (grid:st-type arg)))
+                                (grid:st-symbol arg)))
+                        (mapcar 'grid:st-pointer-generic-pointer
+                                c-arguments))
+                       (list (grid:st-type creturn-st))))))
+             ,@(case c-return
+                 (:void `((declare (ignore ,(grid:st-symbol creturn-st)))))
+                 (:error-code		; fill in arguments
+                  `((check-gsl-status ,(grid:st-symbol creturn-st)
+                                      ',(or (defgeneric-method-p name) name)))))
+             ,@(when (eq (grid:st-type creturn-st) :pointer)
+                 `((check-null-pointer
+                    ,(grid:st-symbol creturn-st)
+                    ,@'('memory-allocation-failure "No memory allocated."))))
+             ,@after
+             ,(values-unless-singleton
+               (defmfun-return
+                   c-return (grid:st-symbol creturn-st) clret
+                 allocated-return
+                 return return-supplied-p
+                 enumeration outputs)))))))))
 
 (defun defmfun-return
     (c-return cret-name clret allocated return return-supplied-p enumeration outputs)
diff --git a/init/defmfun-single.lisp b/init/defmfun-single.lisp
index 3e1db2c..4cb076d 100644
--- a/init/defmfun-single.lisp
+++ b/init/defmfun-single.lisp
@@ -102,8 +102,7 @@
 			    (when auxstart
 			      (apply
 			       'append
-			       (mapcar 'rest (remove-if 'atom auxstart)))))))))))
-	     (first callback-dynamic-variables))
+			       (mapcar 'rest (remove-if 'atom auxstart))))))))))))
 	   ,@(when documentation (list documentation))
 	   ,(funcall body-maker name arglist gsl-name c-arguments key-args))
 	`(,defn
diff --git a/tests/numerical-integration.lisp b/tests/numerical-integration.lisp
index 7f1e0a8..6f22224 100644
--- a/tests/numerical-integration.lisp
+++ b/tests/numerical-integration.lisp
@@ -232,5 +232,12 @@
      (LIST -0.08994400695837003d0 1.18529017636488d-6)
      (MULTIPLE-VALUE-LIST
       (INTEGRATION-QAWC 'INTEGRATION-TEST-F459 -1.0d0 5.0d0
-			0.0d0 0.0d0 0.001d0 1000)))))
-
+			0.0d0 0.0d0 0.001d0 1000))))
+  (LISP-UNIT:ASSERT-NUMERICAL-EQUAL (LIST 1.0d0 1.1102230246251565d-14)
+                                    (MULTIPLE-VALUE-LIST
+                                     (INTEGRATION-QAG
+                                      (LAMBDA (X)
+                                        (INTEGRATION-QAG
+                                         (LAMBDA (Y) (* (SIN X) Y)) 0.0d0 1.0d0
+                                         :GAUSS41))
+                                      0.0d0 PI :GAUSS41))))
-- 
1.8.3.1


