~ chicken-core (chicken-5) bf0e0c03c9f3b7cff57848e1655c79505125b87a

commit bf0e0c03c9f3b7cff57848e1655c79505125b87a
Author:     Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Mon Aug 26 16:05:43 2013 +0200
Commit:     Jim Ursetto <zbigniewsz@gmail.com>
CommitDate: Tue Aug 27 21:28:18 2013 -0500

    Fix TMPDIR handling in chicken-install (#1048)
    
    - Clean up make-install-command so it doesn't depend too much on the
       e+d+v list structure used elsewhere.
    - Don't "override" current-directory as if it were a parameter:
       just change directory back and forth using dynamic-wind.
    
    Signed-off-by: Jim Ursetto <zbigniewsz@gmail.com>

diff --git a/chicken-install.scm b/chicken-install.scm
index cba7765b..45d8c770 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -513,7 +513,7 @@
 		 (and (not (any loop (cdr p))) (fail)))
 		(else (error "invalid `platform' property" name (cadr platform))))))))
 
-  (define (make-install-command e+d+v dep?)
+  (define (make-install-command egg-name egg-version dep?)
     (conc
      *csi*
      " -bnq "
@@ -527,7 +527,7 @@
 	 ""
 	 "-e \"(setup-error-handling)\" ")
      (sprintf "-e \"(extension-name-and-version '(\\\"~a\\\" \\\"~a\\\"))\""
-       (car e+d+v) (caddr e+d+v))
+       egg-name egg-version)
      (if (sudo-install) " -e \"(sudo-install #t)\"" "")
      (if *keep* " -e \"(keep-intermediates #t)\"" "")
      (if (and *no-install* (not dep?)) " -e \"(setup-install-mode #f)\"" "")
@@ -550,7 +550,7 @@
 	 "")
      (if *deploy* " -e \"(deployment-mode #t)\"" "")
      #\space
-     (shellpath (make-pathname (cadr e+d+v) (car e+d+v) "setup"))) )
+     (shellpath (string-append egg-name ".setup"))) )
 
   (define-syntax keep-going
     (syntax-rules ()
@@ -610,26 +610,33 @@
 	       (let ((setup
 		      (lambda (dir)
 			(print "changing current directory to " dir)
-			(parameterize ((current-directory dir))
-			  (when *cross-chicken*
-			    (delete-stale-binaries))
-			  (let ((cmd (make-install-command e+d+v (> i 1)))
-				(name (car e+d+v)))
-			    (print "  " cmd)
-			    (keep-going 
-			     (name "installing")
-			     ($system cmd))
-			    (when (and *run-tests*
-				       (not isdep)
-				       (file-exists? "tests")
-				       (directory? "tests")
-				       (file-exists? "tests/run.scm") )
-			      (set! *running-test* #t)
-			      (current-directory "tests")
-			      (keep-going
-			       (name "testing")
-			       (command "~a -s run.scm ~a ~a" *csi* name (caddr e+d+v)))
-			      (set! *running-test* #f)))))))
+			(let ((old-dir (current-directory)))
+			  (dynamic-wind
+			      (lambda ()
+				(change-directory dir))
+			      (lambda ()
+				(when *cross-chicken*
+				      (delete-stale-binaries))
+				(let ((cmd (make-install-command
+					    (car e+d+v) (caddr e+d+v) (> i 1)))
+				      (name (car e+d+v)))
+				  (print "  " cmd)
+				  (keep-going 
+				   (name "installing")
+				   ($system cmd))
+				  (when (and *run-tests*
+					     (not isdep)
+					     (file-exists? "tests")
+					     (directory? "tests")
+					     (file-exists? "tests/run.scm") )
+					(set! *running-test* #t)
+					(current-directory "tests")
+					(keep-going
+					 (name "testing")
+					 (command "~a -s run.scm ~a ~a" *csi* name (caddr e+d+v)))
+					(set! *running-test* #f))))
+			      (lambda ()
+				(change-directory old-dir)))))))
 		 (if (and *target-extension* *host-extension*)
 		     (fluid-let ((*deploy* #f)
 				 (*prefix* #f))