From 7508b498cb6df5e52aae76c2bfb14b4f4067a779 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Mon, 11 Jun 1990 01:18:06 +0000 Subject: [PATCH] Moved defsetfs for sap-ref-mumble from alieneval.lisp to macros.lisp. Rewrote part of naturalize-integer to make it slightly tenser. --- code/alieneval.lisp | 54 ++++++++++++++++++++++----------------------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/code/alieneval.lisp b/code/alieneval.lisp index 22dfb39e5..8673959a4 100644 --- a/code/alieneval.lisp +++ b/code/alieneval.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.1.1.16 1990/06/08 17:59:56 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.1.1.17 1990/06/11 01:18:06 wlott Exp $ ;;; ;;; This file contains any the part of the Alien implementation that ;;; is not part of the compiler. @@ -140,17 +140,6 @@ (type index offset)) (signed-sap-ref-32 sap offset)) -(defsetf sap-ref-8 %set-sap-ref-8) -(defsetf signed-sap-ref-8 %set-sap-ref-8) - -(defsetf sap-ref-16 %set-sap-ref-16) -(defsetf signed-sap-ref-16 %set-sap-ref-16) - -(defsetf sap-ref-32 %set-sap-ref-32) -(defsetf signed-sap-ref-32 %set-sap-ref-32) - -(defsetf sap-ref-sap %set-sap-ref-sap) - (defun %set-sap-ref-8 (sap offset new-value) (declare (type system-area-pointer sap) (type index offset) @@ -534,34 +523,36 @@ #+new-compiler ;;; Naturalize-Integer -- Internal ;;; -;;; Read a possibly signed integer somewhere. For the 16 and 32 bit -;;; cases we let the transform do the work, for random fields we do it -;;; by hand. +;;; Read a possibly signed integer somewhere. ;;; (defun naturalize-integer (signed sap offset size form) - (multiple-value-bind (q r) (truncate offset alien-alignment) + (declare (type boolean signed) + (type system-area-pointer sap) + (type index offset size)) + (let ((bit-offset (logand offset #x1f))) (cond - ((and (= size 32) (zerop r)) + ((and (= size 32) (zerop bit-offset)) (if signed - (signed-sap-ref-32 sap q) - (sap-ref-32 sap q))) - ((and (= size 16) (zerop (logand r #xf))) + (signed-sap-ref-32 sap (ash offset -5)) + (sap-ref-32 sap (ash offset -5)))) + ((and (= size 16) (zerop (logand offset #xf))) (if signed (signed-sap-ref-16 sap (ash offset -4)) (sap-ref-16 sap (ash offset -4)))) - ((and (= size 8) (zerop (logand r #x7))) + ((and (= size 8) (zerop (logand offset #x7))) (if signed (signed-sap-ref-8 sap (ash offset -3)) (sap-ref-8 sap (ash offset -3)))) ((> size 32) (error "Access of ~D bit integers is not supported:~% ~S" size form)) - ((zerop r) - (let ((value (ldb (byte size 0) (sap-ref-32 sap q)))) + ((zerop bit-offset) + (let ((value (ldb (byte size 0) (sap-ref-32 sap (ash offset -5))))) (if (and signed (logbitp value (1- size))) (logior value (ash -1 size)) value))) - ((<= (+ size r) 32) - (let ((value (ldb (byte size r) (sap-ref-32 sap q)))) + ((<= (+ size bit-offset) 32) + (let ((value (ldb (byte size bit-offset) + (sap-ref-32 sap (ash offset -5))))) (if (and signed (logbitp value (1- size))) (logior value (ash -1 size)) value))) @@ -574,7 +565,7 @@ (ecase vm:target-byte-order (:little-endian '(1+ offset)) (:bit-endian 'offset)))) - (let* ((high-bits (- 32 r)) + (let* ((high-bits (- 32 bit-offset)) (low-bits (- size high-bits)) (value (logior (ash (ldb (byte high-bits 0) (sap-ref-32 sap (high-byte))) @@ -583,7 +574,7 @@ (- (- 32 low-bits)))))) (if (and signed (logbitp value (1- size))) (logior value (ash -1 size)) - value))))))) + value)))))) #+new-compiler @@ -592,6 +583,10 @@ ;;; Like Naturalize-Integer, but writes an integer. ;;; (defun deport-integer (signed sap offset size value form) + (declare (type boolean signed) + (type system-area-pointer sap) + (type index offset size) + (type integer value)) (declare (ignore signed)) (multiple-value-bind (q r) (truncate offset 32) (declare (fixnum r)) @@ -636,11 +631,16 @@ ;;; #+new-compiler (defun naturalize-boolean (sap offset size form) + (declare (type system-area-pointer sap) + (type index offset size)) (declare (notinline naturalize-integer)) (not (zerop (naturalize-integer nil sap offset size form)))) ;;; #+new-compiler (defun deport-boolean (sap offset size value form) + (declare (type system-area-pointer sap) + (type index offset size) + (type boolean value)) (declare (notinline deport-integer)) (deport-integer nil sap offset size (if value 1 0) form) nil) -- GitLab