From 500925cf21078c99f28e74308a85567085a4067d Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 1 Oct 1990 17:00:22 +0000
Subject: [PATCH] Added support for reading and setting float variables.

---
 code/debug-int.lisp | 74 +++++++++++++++++++++++++++++++++++++++------
 1 file changed, 64 insertions(+), 10 deletions(-)

diff --git a/code/debug-int.lisp b/code/debug-int.lisp
index 74deb5a6d..be940e95f 100644
--- a/code/debug-int.lisp
+++ b/code/debug-int.lisp
@@ -1001,6 +1001,34 @@
 (defsetf escape-register %set-escape-register)
 
 
+;;; ESCAPE-FLOAT-REGISTER  --  Internal
+;;;
+;;;    Like ESCAPE-REGISTER, but returns the value of a float register.  Format
+;;; is the type of float to return.
+;;;
+(defun escape-float-register (scp index format)
+  (alien-bind ((sc scp mach:sigcontext t)
+	       (fpregs (mach:sigcontext-fpregs (alien-value sc))
+		       mach:int-array t))
+    (let ((sap (alien-sap fpregs)))
+      (ecase format
+	(single-float (sap-ref-single sap index))
+	(double-float (sap-ref-double sap index))))))
+;;;
+(defun %set-escape-float-register (scp index format new-value)
+  (alien-bind ((sc scp mach:sigcontext t)
+	       (fpregs (mach:sigcontext-fpregs (alien-value sc))
+		       mach:int-array t))
+    (let ((sap (alien-sap fpregs)))
+      (ecase format
+	(single-float
+	 (setf (sap-ref-single sap index) new-value))
+	(double-float
+	 (setf (sap-ref-double sap index) new-value))))))
+;;;
+(defsetf escape-float-register %set-escape-float-register)
+
+
 ;;; DEBUG-FUNCTION-FROM-PC -- Internal.
 ;;;
 ;;; This returns a compiled-debug-function for code and pc.  We fetch the
@@ -2125,6 +2153,12 @@
 				 (c::sc-offset-offset sc-offset))))
 		      ,@forms)
 		    :invalid-value-for-unescaped-register-storage))
+	     (escaped-float-value (format)
+	       `(if escaped
+		    (escape-float-register escaped
+					   (c::sc-offset-offset sc-offset)
+					   ',format)
+		    :invalid-value-for-unescaped-register-storage))
 	     (with-nfp ((var) &body body)
 	       `(let ((,var (if escaped
 				(int-sap (escape-register escaped
@@ -2154,11 +2188,16 @@
        (error "Local non-descriptor register access?"))
       (#.c:interior-reg-sc-number
        (error "Local interior register access?"))
-      ((#.c:single-reg-sc-number
-	#.c:double-reg-sc-number
-	#.c:single-stack-sc-number
-	#.c:double-stack-sc-number)
-       (error "No floating point stuff yet."))
+      (#.c:single-reg-sc-number
+       (escaped-float-value single-float))
+      (#.c:double-reg-sc-number
+       (escaped-float-value double-float))
+      (#.c:single-stack-sc-number
+       (with-nfp (nfp)
+	 (sap-ref-single nfp (c::sc-offset-offset sc-offset))))
+      (#.c:double-stack-sc-number
+       (with-nfp (nfp)
+	 (sap-ref-double nfp (c::sc-offset-offset sc-offset))))
       (#.c:control-stack-sc-number
        (stack-ref fp (c::sc-offset-offset sc-offset)))
       (#.c:base-character-stack-sc-number
@@ -2231,6 +2270,14 @@
 					   (c::sc-offset-offset sc-offset))
 			  ,val)
 		    value))
+	     (set-escaped-float-value (format val)
+	       `(if escaped
+		    (setf (escape-float-register
+			   escaped
+			   (c::sc-offset-offset sc-offset)
+			   ',format)
+			  ,val)
+		    value))
 	     (with-nfp ((var) &body body)
 	       `(let ((,var (if escaped
 				(int-sap (escape-register escaped
@@ -2254,11 +2301,18 @@
        (error "Local non-descriptor register access?"))
       (#.c:interior-reg-sc-number
        (error "Local interior register access?"))
-      ((#.c:single-reg-sc-number
-	#.c:double-reg-sc-number
-	#.c:single-stack-sc-number
-	#.c:double-stack-sc-number)
-       (error "No floating point stuff yet."))
+      (#.c:single-reg-sc-number
+       (set-escaped-float-value single-float value))
+      (#.c:double-reg-sc-number
+       (set-escaped-float-value double-float value))
+      (#.c:single-stack-sc-number
+       (with-nfp (nfp)
+	 (setf (sap-ref-single nfp (c::sc-offset-offset sc-offset))
+	       (the single-float value))))
+      (#.c:double-stack-sc-number
+       (with-nfp (nfp)
+	 (setf (sap-ref-double nfp (c::sc-offset-offset sc-offset))
+	       (the double-float value))))
       (#.c:control-stack-sc-number
        (setf (stack-ref fp (c::sc-offset-offset sc-offset)) value))
       (#.c:base-character-stack-sc-number
-- 
GitLab