Skip to content
Snippets Groups Projects
Commit b10c6178 authored by wlott's avatar wlott
Browse files

Wrote FIXUP-CODE-OBJECT.

parent ec0e4fbc
No related branches found
No related tags found
No related merge requests found
......@@ -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)))))))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment