X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fkernel.lisp;h=c0e455715395b6a7f38b9dc688070faf0da546d8;hb=b14a61c6af3e3005c94e633e727177346240066e;hp=ad5d8158de9ba7c2d71954c49781d298ab5f1750;hpb=08917ec0d00a781a1089922a5419b7f136cdf08f;p=sbcl.git

diff --git a/src/code/kernel.lisp b/src/code/kernel.lisp
index ad5d815..c0e4557 100644
--- a/src/code/kernel.lisp
+++ b/src/code/kernel.lisp
@@ -21,8 +21,13 @@
 (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))
 
@@ -73,6 +78,57 @@
 (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))
@@ -84,6 +140,9 @@
 (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))
@@ -94,19 +153,43 @@
 (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.