1 ;;;; miscellaneous kernel-level definitions
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!KERNEL")
14 ;;; Return the 24 bits of data in the header of object X, which must
15 ;;; be an other-pointer object.
16 (defun get-header-data (x)
19 ;;; Set the 24 bits of data in the header of object X (which must be
20 ;;; an other-pointer object) to VAL.
21 (defun set-header-data (x val
)
22 (set-header-data x val
))
24 ;;; the length of the closure X, i.e. one more than the
25 ;;; number of variables closed over
26 (defun get-closure-length (x)
27 (get-closure-length x
))
35 ;;; Return a System-Area-Pointer pointing to the data for the vector
36 ;;; X, which must be simple.
38 ;;; FIXME: So it should be SIMPLE-VECTOR-SAP, right? (or UNHAIRY-VECTOR-SAP,
39 ;;; if the meaning is (SIMPLE-ARRAY * 1) instead of SIMPLE-VECTOR)
40 ;;; (or maybe SIMPLE-VECTOR-DATA-SAP or UNHAIRY-VECTOR-DATA-SAP?)
42 (declare (type (simple-unboxed-array (*)) x
))
45 ;;; Return a System-Area-Pointer pointing to the end of the binding stack.
46 (defun sb!c
::binding-stack-pointer-sap
()
47 (sb!c
::binding-stack-pointer-sap
))
49 ;;; Return a System-Area-Pointer pointing to the next free word of the
50 ;;; current dynamic space.
51 (defun sb!c
::dynamic-space-free-pointer
()
52 (sb!c
::dynamic-space-free-pointer
))
54 ;;; Return a System-Area-Pointer pointing to the end of the control stack.
55 (defun sb!c
::control-stack-pointer-sap
()
56 (sb!c
::control-stack-pointer-sap
))
58 ;;; Return the header typecode for FUNCTION. Can be set with SETF.
59 (defun fun-subtype (function)
60 (fun-subtype function
))
61 (defun (setf fun-subtype
) (type function
)
62 (setf (fun-subtype function
) type
))
64 ;;; Extract the arglist from the function header FUNC.
65 (defun %simple-fun-arglist
(func)
66 (%simple-fun-arglist func
))
68 ;;; Extract the name from the function header FUNC.
69 (defun %simple-fun-name
(func)
70 (%simple-fun-name func
))
72 ;;; Extract the type from the function header FUNC.
73 (defun %simple-fun-type
(func)
74 (%simple-fun-type func
))
76 (defun %simple-fun-next
(simple-fun)
77 (%simple-fun-next simple-fun
))
79 (defun %simple-fun-self
(simple-fun)
80 (%simple-fun-self simple-fun
))
82 ;;; Extract the function from CLOSURE.
83 (defun %closure-fun
(closure)
84 (%closure-fun closure
))
86 ;;; Return the length of VECTOR. There is no reason to use this in
87 ;;; ordinary code, 'cause length (the vector foo)) is the same.
88 (defun sb!c
::vector-length
(vector)
89 (sb!c
::vector-length vector
))
91 ;;; Extract the INDEXth slot from CLOSURE.
92 (defun %closure-index-ref
(closure index
)
93 (%closure-index-ref closure index
))
95 ;;; Allocate a unboxed, simple vector with type code TYPE, length LENGTH, and
96 ;;; WORDS words long. Note: it is your responsibility to ensure that the
97 ;;; relation between LENGTH and WORDS is correct.
98 (defun allocate-vector (type length words
)
99 (allocate-vector type length words
))
101 ;;; Allocate an array header with type code TYPE and rank RANK.
102 (defun make-array-header (type rank
)
103 (make-array-header type rank
))
105 ;;; Return a SAP pointing to the instructions part of CODE-OBJ.
106 (defun code-instructions (code-obj)
107 (code-instructions code-obj
))
109 ;;; Extract the INDEXth element from the header of CODE-OBJ. Can be
111 (defun code-header-ref (code-obj index
)
112 (code-header-ref code-obj index
))
114 (defun code-header-set (code-obj index new
)
115 (code-header-set code-obj index new
))
117 (defun %raw-bits
(object offset
)
118 (declare (type index offset
))
119 (sb!kernel
:%raw-bits object offset
))
121 (defun %set-raw-bits
(object offset value
)
122 (declare (type index offset
))
123 (declare (type (unsigned-byte #.sb
!vm
:n-word-bits
) value
))
124 (setf (sb!kernel
:%raw-bits object offset
) value
))
126 (defun make-single-float (x) (make-single-float x
))
127 (defun make-double-float (hi lo
) (make-double-float hi lo
))
129 (defun make-long-float (exp hi
#!+sparc mid lo
)
130 (make-long-float exp hi
#!+sparc mid lo
))
131 (defun single-float-bits (x) (single-float-bits x
))
132 (defun double-float-high-bits (x) (double-float-high-bits x
))
133 (defun double-float-low-bits (x) (double-float-low-bits x
))
135 (defun long-float-exp-bits (x) (long-float-exp-bits x
))
137 (defun long-float-high-bits (x) (long-float-high-bits x
))
138 #!+(and long-float sparc
)
139 (defun long-float-mid-bits (x) (long-float-mid-bits x
))
141 (defun long-float-low-bits (x) (long-float-low-bits x
))