From b10c61784b353dca1e36875efa17b66ec9719d0f Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Mon, 22 Apr 1991 19:22:51 +0000 Subject: [PATCH] Wrote FIXUP-CODE-OBJECT. --- code/rt-vm.lisp | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/code/rt-vm.lisp b/code/rt-vm.lisp index 2bc340174..7db3bb03a 100644 --- a/code/rt-vm.lisp +++ b/code/rt-vm.lisp @@ -7,11 +7,11 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/rt-vm.lisp,v 1.1 1991/04/16 19:33:16 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/rt-vm.lisp,v 1.2 1991/04/22 19:22:51 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/rt-vm.lisp,v 1.1 1991/04/16 19:33:16 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/rt-vm.lisp,v 1.2 1991/04/22 19:22:51 wlott Exp $ ;;; ;;; This file contains the RT specific runtime stuff. ;;; @@ -44,7 +44,24 @@ ;;; FIXUP-CODE-OBJECT -- Interface ;;; (defun fixup-code-object (code offset fixup kind) - (error "Not yet." code offset fixup kind)) + (declare (type index offset) (type (unsigned-byte 32) fixup)) + (system:without-gcing + (let ((sap (sap+ (kernel:code-instructions code) offset))) + (ecase kind + (:cal + (setf (sap-ref-16 sap 1) + (ldb (byte 16 0) fixup))) + (:cau + (let ((high (ldb (byte 16 16) fixup))) + (setf (sap-ref-16 sap 1) + (if (logbitp 15 fixup) (1+ high) high)))) + (:ba + (unless (zerop (ash fixup -24)) + (warn "#x~8,'0X out of range for branch-absolute." fixup)) + (setf (sap-ref-8 sap 1) + (ldb (byte 8 16) fixup)) + (setf (sap-ref-16 sap 1) + (ldb (byte 16 0) fixup))))))) -- GitLab