Skip to content
Snippets Groups Projects
sap.lisp 5.95 KiB
Newer Older
wlott's avatar
wlott committed
;;; -*- Package: SYSTEM -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sap.lisp,v 1.6 1992/02/15 12:56:50 wlott Exp $")
wlott's avatar
wlott committed
;;;
;;; **********************************************************************
;;;
;;; This file holds the support for System Area Pointers (saps).
;;;
(in-package "SYSTEM")

(export '(system-area-pointer sap-ref-8 sap-ref-16 sap-ref-32 sap-ref-sap
	  signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32
	  sap+ sap- sap< sap<= sap= sap>= sap>
	  allocate-system-memory reallocate-system-memory
	  deallocate-system-memory))
wlott's avatar
wlott committed

(in-package "KERNEL")
(export '(%set-sap-ref-sap %set-sap-ref-32 %set-sap-ref-16
	  %set-sap-ref-8 %set-sap-ref-single %set-sap-ref-double))
(in-package "SYSTEM")

wlott's avatar
wlott committed


;;;; Primitive SAP operations.

(defun sap< (x y)
  "Return T iff the SAP X points to a smaller address then the SAP Y."
  (declare (type system-area-pointer x y))
  (sap< x y))

(defun sap<= (x y)
  "Return T iff the SAP X points to a smaller or the same address as
   the SAP Y."
  (declare (type system-area-pointer x y))
  (sap<= x y))

(defun sap= (x y)
  "Return T iff the SAP X points to the same address as the SAP Y."
  (declare (type system-area-pointer x y))
  (sap= x y))

(defun sap>= (x y)
  "Return T iff the SAP X points to a larger or the same address as
   the SAP Y."
  (declare (type system-area-pointer x y))
  (sap>= x y))

(defun sap> (x y)
  "Return T iff the SAP X points to a larger address then the SAP Y."
  (declare (type system-area-pointer x y))
wlott's avatar
wlott committed

(defun sap+ (sap offset)
  "Return a new sap OFFSET bytes from SAP."
  (declare (type system-area-pointer sap)
	   (fixnum offset))
  (sap+ sap offset))

(defun sap- (sap1 sap2)
  "Return the byte offset between SAP1 and SAP2."
  (declare (type system-area-pointer sap1 sap2))
  (sap- sap1 sap2))

(defun sap-int (sap)
  "Converts a System Area Pointer into an integer."
  (declare (type system-area-pointer sap))
  (sap-int sap))

(defun int-sap (int)
  "Converts an integer into a System Area Pointer."
  (declare (type (unsigned-byte #.vm:word-bits) int))
  (int-sap int))

(defun sap-ref-8 (sap offset)
  "Returns the 8-bit byte at OFFSET bytes from SAP."
  (declare (type system-area-pointer sap)
	   (type index offset))
  (sap-ref-8 sap offset))

(defun sap-ref-16 (sap offset)
  "Returns the 16-bit word at OFFSET half-words from SAP."
  (declare (type system-area-pointer sap)
	   (type index offset))
  (sap-ref-16 sap offset))

(defun sap-ref-32 (sap offset)
  "Returns the 32-bit dualword at OFFSET words from SAP."
  (declare (type system-area-pointer sap)
	   (type index offset))
  (sap-ref-32 sap offset))

(defun sap-ref-sap (sap offset)
  "Returns the 32-bit system-area-pointer at OFFSET words from SAP."
  (declare (type system-area-pointer sap)
	   (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)
	   (type index offset))
  (signed-sap-ref-8 sap offset))

(defun signed-sap-ref-16 (sap offset)
  "Returns the signed 16-bit word at Offset words from SAP."
  (declare (type system-area-pointer sap)
	   (type index offset))
  (signed-sap-ref-16 sap offset))

(defun signed-sap-ref-32 (sap offset)
  "Returns the signed 32-bit dualword at Offset words from SAP."
  (declare (type system-area-pointer sap)
	   (type index offset))
  (signed-sap-ref-32 sap offset))

(defun %set-sap-ref-8 (sap offset new-value)
  (declare (type system-area-pointer sap)
	   (type index offset)
	   (type (or (signed-byte 8) (unsigned-byte 8)) new-value))
  (setf (sap-ref-8 sap offset) new-value))

(defun %set-sap-ref-16 (sap offset new-value)
  (declare (type system-area-pointer sap)
	   (type index offset)
	   (type (or (signed-byte 16) (unsigned-byte 16)) new-value))
  (setf (sap-ref-16 sap offset) new-value))

(defun %set-sap-ref-32 (sap offset new-value)
  (declare (type system-area-pointer sap)
	   (type index offset)
	   (type (or (signed-byte 32) (unsigned-byte 32)) new-value))
  (if (minusp new-value)
      (truly-the (signed-byte 32) (setf (sap-ref-32 sap offset) new-value))
      (truly-the (unsigned-byte 32) (setf (sap-ref-32 sap offset) new-value))))

(defun %set-sap-ref-sap (sap offset new-value)
  (declare (type system-area-pointer sap 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))



;;;; System memory allocation.

(alien:def-alien-routine ("os_allocate" allocate-system-memory)
			 system-area-pointer
  (bytes c-call:unsigned-long))
wlott's avatar
wlott committed

(alien:def-alien-routine ("os_reallocate" reallocate-system-memory)
			 system-area-pointer
  (old system-area-pointer)
  (old-size c-call:unsigned-long)
  (new-size c-call:unsigned-long))
wlott's avatar
wlott committed

(alien:def-alien-routine ("os_deallocate" deallocate-system-memory)
			 c-call:void
  (addr system-area-pointer)
  (bytes c-call:unsigned-long))