home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / sap.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  6.6 KB  |  215 lines
  1. ;;; -*- Package: SYSTEM -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: sap.lisp,v 1.9 92/03/02 02:23:17 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This file holds the support for System Area Pointers (saps).
  15. ;;;
  16. (in-package "SYSTEM")
  17.  
  18. (export '(system-area-pointer sap-ref-8 sap-ref-16 sap-ref-32 sap-ref-sap
  19.       signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32
  20.       sap+ sap- sap< sap<= sap= sap>= sap>
  21.       allocate-system-memory allocate-system-memory-at
  22.       reallocate-system-memory deallocate-system-memory))
  23.  
  24. (in-package "KERNEL")
  25. (export '(%set-sap-ref-sap %set-sap-ref-single %set-sap-ref-double
  26.       %set-sap-ref-8 %set-signed-sap-ref-8
  27.       %set-sap-ref-16 %set-signed-sap-ref-16
  28.       %set-sap-ref-32 %set-signed-sap-ref-32))
  29. (in-package "SYSTEM")
  30.  
  31. (use-package "KERNEL")
  32.  
  33.  
  34.  
  35. ;;;; Primitive SAP operations.
  36.  
  37. (defun sap< (x y)
  38.   "Return T iff the SAP X points to a smaller address then the SAP Y."
  39.   (declare (type system-area-pointer x y))
  40.   (sap< x y))
  41.  
  42. (defun sap<= (x y)
  43.   "Return T iff the SAP X points to a smaller or the same address as
  44.    the SAP Y."
  45.   (declare (type system-area-pointer x y))
  46.   (sap<= x y))
  47.  
  48. (defun sap= (x y)
  49.   "Return T iff the SAP X points to the same address as the SAP Y."
  50.   (declare (type system-area-pointer x y))
  51.   (sap= x y))
  52.  
  53. (defun sap>= (x y)
  54.   "Return T iff the SAP X points to a larger or the same address as
  55.    the SAP Y."
  56.   (declare (type system-area-pointer x y))
  57.   (sap>= x y))
  58.  
  59. (defun sap> (x y)
  60.   "Return T iff the SAP X points to a larger address then the SAP Y."
  61.   (declare (type system-area-pointer x y))
  62.   (sap> x y))
  63.  
  64. (defun sap+ (sap offset)
  65.   "Return a new sap OFFSET bytes from SAP."
  66.   (declare (type system-area-pointer sap)
  67.        (fixnum offset))
  68.   (sap+ sap offset))
  69.  
  70. (defun sap- (sap1 sap2)
  71.   "Return the byte offset between SAP1 and SAP2."
  72.   (declare (type system-area-pointer sap1 sap2))
  73.   (sap- sap1 sap2))
  74.  
  75. (defun sap-int (sap)
  76.   "Converts a System Area Pointer into an integer."
  77.   (declare (type system-area-pointer sap))
  78.   (sap-int sap))
  79.  
  80. (defun int-sap (int)
  81.   "Converts an integer into a System Area Pointer."
  82.   (declare (type (unsigned-byte #.vm:word-bits) int))
  83.   (int-sap int))
  84.  
  85. (defun sap-ref-8 (sap offset)
  86.   "Returns the 8-bit byte at OFFSET bytes from SAP."
  87.   (declare (type system-area-pointer sap)
  88.        (type index offset))
  89.   (sap-ref-8 sap offset))
  90.  
  91. (defun sap-ref-16 (sap offset)
  92.   "Returns the 16-bit word at OFFSET bytes from SAP."
  93.   (declare (type system-area-pointer sap)
  94.        (type index offset))
  95.   (sap-ref-16 sap offset))
  96.  
  97. (defun sap-ref-32 (sap offset)
  98.   "Returns the 32-bit dualword at OFFSET bytes from SAP."
  99.   (declare (type system-area-pointer sap)
  100.        (type index offset))
  101.   (sap-ref-32 sap offset))
  102.  
  103. (defun sap-ref-sap (sap offset)
  104.   "Returns the 32-bit system-area-pointer at OFFSET bytes from SAP."
  105.   (declare (type system-area-pointer sap)
  106.        (type index offset))
  107.   (sap-ref-sap sap offset))
  108.  
  109. (defun sap-ref-single (sap offset)
  110.   "Returns the 32-bit single-float at OFFSET bytes from SAP."
  111.   (declare (type system-area-pointer sap)
  112.        (type index offset))
  113.   (sap-ref-single sap offset))
  114.  
  115. (defun sap-ref-double (sap offset)
  116.   "Returns the 64-bit double-float at OFFSET bytes from SAP."
  117.   (declare (type system-area-pointer sap)
  118.        (type index offset))
  119.   (sap-ref-double sap offset))
  120.  
  121. (defun signed-sap-ref-8 (sap offset)
  122.   "Returns the signed 8-bit byte at OFFSET bytes from SAP."
  123.   (declare (type system-area-pointer sap)
  124.        (type index offset))
  125.   (signed-sap-ref-8 sap offset))
  126.  
  127. (defun signed-sap-ref-16 (sap offset)
  128.   "Returns the signed 16-bit word at OFFSET bytes from SAP."
  129.   (declare (type system-area-pointer sap)
  130.        (type index offset))
  131.   (signed-sap-ref-16 sap offset))
  132.  
  133. (defun signed-sap-ref-32 (sap offset)
  134.   "Returns the signed 32-bit dualword at OFFSET bytes from SAP."
  135.   (declare (type system-area-pointer sap)
  136.        (type index offset))
  137.   (signed-sap-ref-32 sap offset))
  138.  
  139. (defun %set-sap-ref-8 (sap offset new-value)
  140.   (declare (type system-area-pointer sap)
  141.        (type index offset)
  142.        (type (unsigned-byte 8) new-value))
  143.   (setf (sap-ref-8 sap offset) new-value))
  144.  
  145. (defun %set-sap-ref-16 (sap offset new-value)
  146.   (declare (type system-area-pointer sap)
  147.        (type index offset)
  148.        (type (unsigned-byte 16) new-value))
  149.   (setf (sap-ref-16 sap offset) new-value))
  150.  
  151. (defun %set-sap-ref-32 (sap offset new-value)
  152.   (declare (type system-area-pointer sap)
  153.        (type index offset)
  154.        (type (unsigned-byte 32) new-value))
  155.   (setf (sap-ref-32 sap offset) new-value))
  156.  
  157. (defun %set-signed-sap-ref-8 (sap offset new-value)
  158.   (declare (type system-area-pointer sap)
  159.        (type index offset)
  160.        (type (signed-byte 8) new-value))
  161.   (setf (signed-sap-ref-8 sap offset) new-value))
  162.  
  163. (defun %set-signed-sap-ref-16 (sap offset new-value)
  164.   (declare (type system-area-pointer sap)
  165.        (type index offset)
  166.        (type (signed-byte 16) new-value))
  167.   (setf (signed-sap-ref-16 sap offset) new-value))
  168.  
  169. (defun %set-signed-sap-ref-32 (sap offset new-value)
  170.   (declare (type system-area-pointer sap)
  171.        (type index offset)
  172.        (type (signed-byte 32) new-value))
  173.   (setf (signed-sap-ref-32 sap offset) new-value))
  174.  
  175. (defun %set-sap-ref-sap (sap offset new-value)
  176.   (declare (type system-area-pointer sap new-value)
  177.        (type index offset))
  178.   (setf (sap-ref-sap sap offset) new-value))
  179.  
  180. (defun %set-sap-ref-single (sap offset new-value)
  181.   (declare (type system-area-pointer sap)
  182.        (type index offset)
  183.        (type single-float new-value))
  184.   (setf (sap-ref-single sap offset) new-value))
  185.  
  186. (defun %set-sap-ref-double (sap offset new-value)
  187.   (declare (type system-area-pointer sap)
  188.        (type index offset)
  189.        (type double-float new-value))
  190.   (setf (sap-ref-double sap offset) new-value))
  191.  
  192.  
  193.  
  194. ;;;; System memory allocation.
  195.  
  196. (alien:def-alien-routine ("os_allocate" allocate-system-memory)
  197.              system-area-pointer
  198.   (bytes c-call:unsigned-long))
  199.  
  200. (alien:def-alien-routine ("os_allocate_at" allocate-system-memory-at)
  201.              system-area-pointer
  202.   (address system-area-pointer)
  203.   (bytes c-call:unsigned-long))
  204.  
  205. (alien:def-alien-routine ("os_reallocate" reallocate-system-memory)
  206.              system-area-pointer
  207.   (old system-area-pointer)
  208.   (old-size c-call:unsigned-long)
  209.   (new-size c-call:unsigned-long))
  210.  
  211. (alien:def-alien-routine ("os_deallocate" deallocate-system-memory)
  212.              c-call:void
  213.   (addr system-area-pointer)
  214.   (bytes c-call:unsigned-long))
  215.