(defun set-header-data (x val)
(set-header-data x val))
-;;; the length of the closure X, i.e. one more than the
-;;; number of variables closed over
+;;; Return the 24 bits of data in the header of object X, which must
+;;; be a fun-pointer object.
+;;;
+;;; FIXME: Should this not be called GET-FUN-LENGTH instead? Or even better
+;;; yet, if GET-HEADER-DATA masked the lowtag instead of substracting it, we
+;;; could just use it instead -- or at least this could just be a function on
+;;; top of the same VOP.
(defun get-closure-length (x)
(get-closure-length x))
(defun widetag-of (x)
(widetag-of x))
+;;; WIDETAG-OF needs extra code to handle LIST and FUNCTION lowtags. When
+;;; we're only dealing with other pointers (eg. when dispatching on array
+;;; element type), this is going to be faster.
+(declaim (inline %other-pointer-widetag))
+(defun %other-pointer-widetag (x)
+ (sb!sys:sap-ref-8 (int-sap (get-lisp-obj-address x))
+ #.(ecase sb!c:*backend-byte-order*
+ (:little-endian
+ (- sb!vm:other-pointer-lowtag))
+ (:big-endian
+ (- (1- sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag)))))
+
;;; Return a System-Area-Pointer pointing to the data for the vector
;;; X, which must be simple.
;;;
(sb!c::control-stack-pointer-sap))
;;; Return the header typecode for FUNCTION. Can be set with SETF.
-(defun function-subtype (function)
- (function-subtype function))
-(defun (setf function-subtype) (type function)
- (setf (function-subtype function) type))
+(defun fun-subtype (function)
+ (fun-subtype function))
+(defun (setf fun-subtype) (type function)
+ (setf (fun-subtype function) type))
+
+;;;; SIMPLE-FUN and accessors
+
+(declaim (inline simple-fun-p))
+(defun simple-fun-p (object)
+ (= sb!vm:simple-fun-header-widetag (widetag-of object)))
+
+(deftype simple-fun ()
+ '(satisfies simple-fun-p))
+
+(defun %simple-fun-doc (simple-fun)
+ (declare (simple-fun simple-fun))
+ (let ((info (%simple-fun-info simple-fun)))
+ (cond ((typep info '(or null string))
+ info)
+ ((simple-vector-p info)
+ nil)
+ ((consp info)
+ (car info))
+ (t
+ (bug "bogus INFO for ~S: ~S" simple-fun info)))))
+
+(defun (setf %simple-fun-doc) (doc simple-fun)
+ (declare (type (or null string) doc)
+ (simple-fun simple-fun))
+ (let ((info (%simple-fun-info simple-fun)))
+ (setf (%simple-fun-info simple-fun)
+ (cond ((typep info '(or null string))
+ doc)
+ ((simple-vector-p info)
+ (if doc
+ (cons doc info)
+ info))
+ ((consp info)
+ (if doc
+ (cons doc (cdr info))
+ (cdr info)))
+ (t
+ (bug "bogus INFO for ~S: ~S" simple-fun info))))))
+
+(defun %simple-fun-xrefs (simple-fun)
+ (declare (simple-fun simple-fun))
+ (let ((info (%simple-fun-info simple-fun)))
+ (cond ((typep info '(or null string))
+ nil)
+ ((simple-vector-p info)
+ info)
+ ((consp info)
+ (cdr info))
+ (t
+ (bug "bogus INFO for ~S: ~S" simple-fun info)))))
;;; Extract the arglist from the function header FUNC.
(defun %simple-fun-arglist (func)
(%simple-fun-arglist func))
+(defun (setf %simple-fun-arglist) (new-value func)
+ (setf (%simple-fun-arglist func) new-value))
+
;;; Extract the name from the function header FUNC.
(defun %simple-fun-name (func)
(%simple-fun-name func))
+(defun (setf %simple-fun-name) (new-value func)
+ (setf (%simple-fun-name func) new-value))
+
;;; Extract the type from the function header FUNC.
(defun %simple-fun-type (func)
(%simple-fun-type func))
(defun %simple-fun-self (simple-fun)
(%simple-fun-self simple-fun))
+;;;; CLOSURE type and accessors
+
+(declaim (inline closurep))
+(defun closurep (object)
+ (= sb!vm:closure-header-widetag (widetag-of object)))
+
+(deftype closure ()
+ '(satisfies closurep))
+
+(defmacro do-closure-values ((value closure) &body body)
+ (with-unique-names (i nclosure)
+ `(let ((,nclosure ,closure))
+ (declare (closure ,nclosure))
+ (dotimes (,i (- (1+ (get-closure-length ,nclosure)) sb!vm:closure-info-offset))
+ (let ((,value (%closure-index-ref ,nclosure ,i)))
+ ,@body)))))
+
+(defun %closure-values (closure)
+ (declare (closure closure))
+ (let (values)
+ (do-closure-values (elt closure)
+ (push elt values))
+ (nreverse values)))
+
;;; Extract the function from CLOSURE.
(defun %closure-fun (closure)
(%closure-fun closure))
+;;; Extract the INDEXth slot from CLOSURE.
+(defun %closure-index-ref (closure index)
+ (%closure-index-ref closure index))
+
;;; Return the length of VECTOR. There is no reason to use this in
;;; ordinary code, 'cause length (the vector foo)) is the same.
(defun sb!c::vector-length (vector)
(sb!c::vector-length vector))
-;;; Extract the INDEXth slot from CLOSURE.
-(defun %closure-index-ref (closure index)
- (%closure-index-ref closure index))
-
;;; Allocate a unboxed, simple vector with type code TYPE, length LENGTH, and
;;; WORDS words long. Note: it is your responsibility to ensure that the
;;; relation between LENGTH and WORDS is correct.
(defun code-header-set (code-obj index new)
(code-header-set code-obj index new))
-(defun %raw-bits (object offset)
+(defun %vector-raw-bits (object offset)
(declare (type index offset))
- (sb!kernel:%raw-bits object offset))
+ (sb!kernel:%vector-raw-bits object offset))
-(defun %set-raw-bits (object offset value)
+(defun %set-vector-raw-bits (object offset value)
(declare (type index offset))
- (declare (type (unsigned-byte #.sb!vm:n-word-bits) value))
- (setf (sb!kernel:%raw-bits object offset) value))
+ (declare (type sb!vm:word value))
+ (setf (sb!kernel:%vector-raw-bits object offset) value))
(defun make-single-float (x) (make-single-float x))
(defun make-double-float (hi lo) (make-double-float hi lo))
-#!+long-float
-(defun make-long-float (exp hi #!+sparc mid lo)
- (make-long-float exp hi #!+sparc mid lo))
+
(defun single-float-bits (x) (single-float-bits x))
(defun double-float-high-bits (x) (double-float-high-bits x))
(defun double-float-low-bits (x) (double-float-low-bits x))
-#!+long-float
-(defun long-float-exp-bits (x) (long-float-exp-bits x))
-#!+long-float
-(defun long-float-high-bits (x) (long-float-high-bits x))
-#!+(and long-float sparc)
-(defun long-float-mid-bits (x) (long-float-mid-bits x))
-#!+long-float
-(defun long-float-low-bits (x) (long-float-low-bits x))
+
projects / sbcl.git / blobdiff