diff --git a/code/hppa-vm.lisp b/code/hppa-vm.lisp index 06269d69c81b0d530b7024d03f8696dd7cf3b894..b8a0a2c293c2714e616c7e3981baab9ddedf43ea 100644 --- a/code/hppa-vm.lisp +++ b/code/hppa-vm.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hppa-vm.lisp,v 1.3 1992/06/18 11:54:21 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hppa-vm.lisp,v 1.4 1992/07/09 16:36:39 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -20,8 +20,9 @@ (use-package "UNIX") (export '(fixup-code-object internal-error-arguments - sigcontext-register sigcontext-float-register - sigcontext-floating-point-modes extern-alien-name)) + sigcontext-program-counter sigcontext-register + sigcontext-float-register sigcontext-floating-point-modes + extern-alien-name)) ;;;; The sigcontext structure. @@ -40,9 +41,9 @@ (sc-fp system-area-pointer) (sc-ap (* save-state)) (sc-pcsqh unsigned-long) - (sc-pc system-area-pointer) ; HP calls it the sc-pcoqh. + (sc-pcoqh unsigned-long) (sc-pcsqt unsigned-long) - (sc-pcoqt system-area-pointer) + (sc-pcoqt unsigned-long) (sc-ps unsigned-long))) @@ -108,7 +109,7 @@ (defun internal-error-arguments (scp) (declare (type (alien (* sigcontext)) scp)) (with-alien ((scp (* sigcontext) scp)) - (let ((pc (slot scp 'sc-pc))) + (let ((pc (sigcontext-program-counter scp))) (declare (type system-area-pointer pc)) (let* ((length (sap-ref-8 pc 4)) (vector (make-array length :element-type '(unsigned-byte 8)))) @@ -130,7 +131,14 @@ ;;;; Sigcontext access functions. -;;; SIGCONTEXT-REGISTER -- Internal. +;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface +;;; +(defun sigcontext-program-counter (scp) + (declare (type (alien (* sigcontext)) scp)) + (with-alien ((scp (* sigcontext) scp)) + (int-sap (logandc2 (slot scp 'sc-pcoqh) 3)))) + +;;; SIGCONTEXT-REGISTER -- Interface ;;; ;;; An escape register saves the value of a register for a frame that someone ;;; interrupts. @@ -149,7 +157,7 @@ (defsetf sigcontext-register %set-sigcontext-register) -;;; SIGCONTEXT-FLOAT-REGISTER -- Internal +;;; SIGCONTEXT-FLOAT-REGISTER -- Interface ;;; ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. ;;; Format is the type of float to return.