diff --git a/code/alieneval.lisp b/code/alieneval.lisp index 6f5b278b21fb370ca66cb903a8b2d71a3952eec2..b923dc31d6cc44dc7b4cf91064edaf54aeaa4212 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.19 1990/06/24 19:35:15 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.1.1.20 1990/07/07 00:51:37 wlott Exp $ ;;; ;;; This file contains any the part of the Alien implementation that ;;; is not part of the compiler. @@ -122,6 +122,18 @@ (type index offset)) (sap-ref-sap sap offset)) +(defun sap-ref-single (sap offset) + "Returns the 32-bit single-float at OFFSET words from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (sap-ref-single sap offset)) + +(defun sap-ref-double (sap offset) + "Returns the 64-bit double-float at OFFSET words from SAP." + (declare (type system-area-pointer sap) + (type index offset)) + (sap-ref-double sap offset)) + (defun signed-sap-ref-8 (sap offset) "Returns the signed 8-bit byte at Offset bytes from SAP." (declare (type system-area-pointer sap) @@ -162,10 +174,21 @@ (defun %set-sap-ref-sap (sap offset new-value) (declare (type system-area-pointer sap new-value) - (type index offset) - (type system-area-pointer new-value)) + (type index offset)) (setf (sap-ref-sap sap offset) new-value)) +(defun %set-sap-ref-single (sap offset new-value) + (declare (type system-area-pointer sap) + (type index offset) + (type single-float new-value)) + (setf (sap-ref-single sap offset) new-value)) + +(defun %set-sap-ref-double (sap offset new-value) + (declare (type system-area-pointer sap) + (type index offset) + (type double-float new-value)) + (setf (sap-ref-double sap offset) new-value)) + ); #+New-Compiler @@ -1064,57 +1087,27 @@ don't know that it is supposed to be used for. I suspect it is a PERQ crock. `(naturalize-boolean ,sap ,offset ,size ',form) `(deport-boolean ,sap ,offset ,size ,value ',form)))) - -;;; Alien-Access expert for short-floats +;;; Alien-Access expert for single-floats ;;; -#+nil ; ### no short floats in the new object format. -(define-alien-access (short-float) (type kind value) +(define-alien-access (single-float) (type kind value) (with-alien (sap) (offset) (size :constant 1) (declare (ignore size)) (if (eq kind :read) - `(%primitive int-sap - (logior (ash (%primitive unsigned-32bit-system-ref ,sap ,offset) - (- clc::short-float-shift-16)) - (ash clc::short-float-4bit-type - (- 32 clc::short-float-shift-16)))) - (let ((var (gensym))) - `(let ((,var (float ,value 1.0s0))) - (setq ,var (ash (%primitive sap-int ,var) clc::short-float-shift-16)) - (%primitive signed-32bit-system-set ,sap ,offset ,var)))))) - + `(sap-ref-single ,sap ,offset) + `(setf (sap-ref-single ,sap ,offset) ,value)))) -;;; Alien-Access expert for long-floats +;;; Alien-Access expert for double-floats ;;; -#+nil ; ### These will need work. -(define-alien-access (long-float) (type kind value) +(define-alien-access (double-float) (type kind value) (with-alien (sap) (offset) (size :unit 64 :constant 1) (declare (ignore size)) (if (eq kind :read) - (let ((var (gensym))) - `(let ((,var (%primitive float-long 0))) - (%primitive 16bit-system-set ,var 2 - (%primitive 16bit-system-ref ,sap ,offset)) - (%primitive 16bit-system-set ,var 3 - (%primitive 16bit-system-ref ,sap (1+ ,offset))) - (%primitive 16bit-system-set ,var 4 - (%primitive 16bit-system-ref ,sap (+ ,offset 2))) - (%primitive 16bit-system-set ,var 5 - (%primitive 16bit-system-ref ,sap (+ ,offset 3))) - ,var)) - (let ((var (gensym))) - `(let ((,var (float ,value 1.0L0))) - (%primitive 16bit-system-set ,sap ,offset - (%primitive 16bit-system-ref ,var 2)) - (%primitive 16bit-system-set ,sap (1+ ,offset) - (%primitive 16bit-system-ref ,var 3)) - (%primitive 16bit-system-set ,sap (+ ,offset 2) - (%primitive 16bit-system-ref ,var 4)) - (%primitive 16bit-system-set ,sap (+ ,offset 3) - (%primitive 16bit-system-ref ,var 5))))))) + `(sap-ref-double ,sap ,offset) + `(setf (sap-ref-double ,sap ,offset) ,value)))) ;;; Alien-access expert for procedure objects. These should be used ;;; with caution.