src/code/kernel.lisp

   1 ;;;; miscellaneous kernel-level definitions
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!KERNEL")
  13
  14 (file-comment
  15   "$Header$")
  16
  17 (defun get-header-data (x)
  18   #!+sb-doc
  19   "Return the 24 bits of data in the header of object X, which must be an
  20   other-pointer object."
  21   (get-header-data x))
  22
  23 (defun set-header-data (x val)
  24   #!+sb-doc
  25   "Sets the 24 bits of data in the header of object X (which must be an
  26   other-pointer object) to VAL."
  27   (set-header-data x val))
  28
  29 (defun get-closure-length (x)
  30   #!+sb-doc
  31   "Returns the length of the closure X. This is one more than the number
  32   of variables closed over."
  33   (get-closure-length x))
  34
  35 (defun get-lowtag (x)
  36   #!+sb-doc
  37   "Returns the three-bit lowtag for the object X."
  38   (get-lowtag x))
  39
  40 (defun get-type (x)
  41   #!+sb-doc
  42   "Returns the 8-bit header type for the object X."
  43   (get-type x))
  44
  45 (defun vector-sap (x)
  46   #!+sb-doc
  47   "Return a System-Area-Pointer pointing to the data for the vector X, which
  48   must be simple."
  49   (declare (type (simple-unboxed-array (*)) x))
  50   (vector-sap x))
  51
  52 (defun sb!c::binding-stack-pointer-sap ()
  53   #!+sb-doc
  54   "Return a System-Area-Pointer pointing to the end of the binding stack."
  55   (sb!c::binding-stack-pointer-sap))
  56
  57 (defun sb!c::dynamic-space-free-pointer ()
  58   #!+sb-doc
  59   "Returns a System-Area-Pointer pointing to the next free work of the current
  60   dynamic space."
  61   (sb!c::dynamic-space-free-pointer))
  62
  63 (defun sb!c::control-stack-pointer-sap ()
  64   #!+sb-doc
  65   "Return a System-Area-Pointer pointing to the end of the control stack."
  66   (sb!c::control-stack-pointer-sap))
  67
  68 (defun function-subtype (function)
  69   #!+sb-doc
  70   "Return the header typecode for FUNCTION. Can be set with SETF."
  71   (function-subtype function))
  72
  73 (defun (setf function-subtype) (type function)
  74   (setf (function-subtype function) type))
  75
  76 (defun %function-arglist (func)
  77   #!+sb-doc
  78   "Extracts the arglist from the function header FUNC."
  79   (%function-arglist func))
  80
  81 (defun %function-name (func)
  82   #!+sb-doc
  83   "Extracts the name from the function header FUNC."
  84   (%function-name func))
  85
  86 (defun %function-type (func)
  87   #!+sb-doc
  88   "Extracts the type from the function header FUNC."
  89   (%function-type func))
  90
  91 (defun %closure-function (closure)
  92   #!+sb-doc
  93   "Extracts the function from CLOSURE."
  94   (%closure-function closure))
  95
  96 (defun sb!c::vector-length (vector)
  97   #!+sb-doc
  98   "Return the length of VECTOR. There is no reason to use this, 'cause
  99   (length (the vector foo)) is the same."
 100   (sb!c::vector-length vector))
 101
 102 (defun %closure-index-ref (closure index)
 103   #!+sb-doc
 104   "Extract the INDEXth slot from CLOSURE."
 105   (%closure-index-ref closure index))
 106
 107 (defun allocate-vector (type length words)
 108   #!+sb-doc
 109   "Allocate a unboxed, simple vector with type code TYPE, length LENGTH, and
 110   WORDS words long. Note: it is your responsibility to ensure that the
 111   relation between LENGTH and WORDS is correct."
 112   (allocate-vector type length words))
 113
 114 (defun make-array-header (type rank)
 115   #!+sb-doc
 116   "Allocate an array header with type code TYPE and rank RANK."
 117   (make-array-header type rank))
 118
 119 (defun code-instructions (code-obj)
 120   #!+sb-doc
 121   "Return a SAP pointing to the instructions part of CODE-OBJ."
 122   (code-instructions code-obj))
 123
 124 (defun code-header-ref (code-obj index)
 125   #!+sb-doc
 126   "Extract the INDEXth element from the header of CODE-OBJ. Can be set with
 127   setf."
 128   (code-header-ref code-obj index))
 129
 130 (defun code-header-set (code-obj index new)
 131   (code-header-set code-obj index new))
 132
 133 (defun %raw-bits (object offset)
 134   (declare (type index offset))
 135   (sb!kernel:%raw-bits object offset))
 136
 137 (defun %set-raw-bits (object offset value)
 138   (declare (type index offset) (type (unsigned-byte #.sb!vm:word-bits) value))
 139   (setf (sb!kernel:%raw-bits object offset) value))
 140
 141 (defun make-single-float (x) (make-single-float x))
 142 (defun make-double-float (hi lo) (make-double-float hi lo))
 143 #!+long-float
 144 (defun make-long-float (exp hi #!+sparc mid lo)
 145   (make-long-float exp hi #!+sparc mid lo))
 146 (defun single-float-bits (x) (single-float-bits x))
 147 (defun double-float-high-bits (x) (double-float-high-bits x))
 148 (defun double-float-low-bits (x) (double-float-low-bits x))
 149 #!+long-float
 150 (defun long-float-exp-bits (x) (long-float-exp-bits x))
 151 #!+long-float
 152 (defun long-float-high-bits (x) (long-float-high-bits x))
 153 #!+(and long-float sparc)
 154 (defun long-float-mid-bits (x) (long-float-mid-bits x))
 155 #!+long-float
 156 (defun long-float-low-bits (x) (long-float-low-bits x))