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