-(defun function-subtype (function)
- #!+sb-doc
- "Return the header typecode for FUNCTION. Can be set with SETF."
- (function-subtype function))
-
-(defun (setf function-subtype) (type function)
- (setf (function-subtype function) type))
-
-(defun %function-arglist (func)
- #!+sb-doc
- "Extracts the arglist from the function header FUNC."
- (%function-arglist func))
-
-(defun %function-name (func)
- #!+sb-doc
- "Extracts the name from the function header FUNC."
- (%function-name func))
-
-(defun %function-type (func)
- #!+sb-doc
- "Extracts the type from the function header FUNC."
- (%function-type func))
-
-(defun %closure-function (closure)
- #!+sb-doc
- "Extracts the function from CLOSURE."
- (%closure-function closure))
+;;; Return the header typecode for FUNCTION. Can be set with SETF.
+(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-next (simple-fun)
+ (%simple-fun-next simple-fun))
+
+(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))