[movitz-cvs] CVS update: movitz/losp/los0.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp
In directory common-lisp.net:/tmp/cvs-serv25211

Modified Files:
	los0.lisp 
Log Message:
Added deinstall-shallow-binding, so we can flip back and forth between
shallow and deep binding at any time.

Date: Wed Nov 17 15:02:19 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.28 movitz/losp/los0.lisp:1.29
--- movitz/losp/los0.lisp:1.28	Wed Nov 17 14:33:11 2004
+++ movitz/losp/los0.lisp	Wed Nov 17 15:02:18 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.28 2004/11/17 13:33:11 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.29 2004/11/17 14:02:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1605,31 +1605,52 @@
     (:ret)))
 
 (defun install-shallow-binding (&key quiet)
+  (unless quiet
+    (warn "Installing shallow-binding strategy.."))
   (without-interrupts
-    (unless quiet
-      (warn "Installing shallow-binding strategy.."))
     (macrolet ((install (slot function)
 		 `(prog1 (cons ',slot (%run-time-context-slot ',slot))
 		    (setf (%run-time-context-slot ',slot) (symbol-value ',function)))))
-      (list (install muerte:dynamic-variable-install dynamic-variable-install-shallow)
-	    (install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow)
-	    (install muerte::dynamic-unwind-next dynamic-unwind-next-shallow)
-	    (install muerte::dynamic-variable-store dynamic-variable-store-shallow)
-	    (install muerte::dynamic-variable-lookup-unbound dynamic-variable-lookup-unbound-shallow)
-	    (prog1 (install muerte::dynamic-variable-lookup dynamic-variable-lookup-shallow)
-	      (labels ((install-shallow-env (env)
-			 "We use this local function in order to install dynamic-env slots
-                          in reverse order, by depth-first recursion."
-			 (unless (eq 0 env)
-			   (install-shallow-env (memref env 12))
-			   (let ((name (memref env 0)))
-			     (when (symbolp name)
-			       (setf (memref env 4)
-				 (%symbol-global-value name))
-			       (setf (%symbol-global-value name)
-				 (memref env 8)))))))
-		(install-shallow-env (load-global-constant dynamic-env
-							   :thread-local t))))))))
+      (prog1
+	  (list (install muerte:dynamic-variable-install dynamic-variable-install-shallow)
+		(install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow)
+		(install muerte::dynamic-unwind-next dynamic-unwind-next-shallow)
+		(install muerte::dynamic-variable-store dynamic-variable-store-shallow)
+		(install muerte::dynamic-variable-lookup-unbound dynamic-variable-lookup-unbound-shallow)
+		(install muerte::dynamic-variable-lookup dynamic-variable-lookup-shallow))
+	(labels ((install-shallow-env (env)
+		   "We use this local function in order to install dynamic-env slots
+                    in reverse order, by depth-first recursion."
+		   (unless (eq 0 env)
+		     (install-shallow-env (memref env 12))
+		     (let ((name (memref env 0)))
+		       (when (symbolp name)
+			 (setf (memref env 4)
+			   (%symbol-global-value name))
+			 (setf (%symbol-global-value name)
+			   (memref env 8)))))))
+	  (install-shallow-env (load-global-constant dynamic-env :thread-local t)))))))
+
+(defun deinstall-shallow-binding (&key quiet)
+  (unless quiet
+    (warn "Deinstalling shallow-binding strategy.."))
+  (without-interrupts
+    (macrolet ((install (slot)
+		 `(setf (%run-time-context-slot ',slot) (symbol-value ',slot))))
+      (install muerte:dynamic-variable-install)
+      (install muerte:dynamic-variable-uninstall)
+      (install muerte::dynamic-unwind-next)
+      (install muerte::dynamic-variable-store)
+      (install muerte::dynamic-variable-lookup-unbound)
+      (install muerte::dynamic-variable-lookup)
+      (loop for env = (load-global-constant dynamic-env :thread-local t)
+	  then (memref env 12)
+	  while (plusp env)
+	  do (let ((name (memref env 0)))
+	       (when (symbolp name)
+		 (setf (%symbol-global-value name)
+		   (memref env 4)))))
+      (values))))
 
 (genesis)