X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-misc.lisp;h=0f65c71acc8690b70627a28a1c0fa6693a589261;hb=8eee0d3a30bf39d9f201acff28c92059fe6c3e4e;hp=a64153827372e1c07a80eef19200e6370c7ebde5;hpb=f12f2c5a8ae794dc414dd6a42e0b25740d576aa1;p=sbcl.git

diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp
index a641538..0f65c71 100644
--- a/src/code/target-misc.lisp
+++ b/src/code/target-misc.lisp
@@ -17,30 +17,46 @@
 ;;;; function names and documentation
 
 ;;;; the ANSI interface to function names (and to other stuff too)
+;;; Note: this function gets called by the compiler (as of 1.0.17.x,
+;;; in MAYBE-INLINE-SYNTACTIC-CLOSURE), and so although ANSI says
+;;; we're allowed to return NIL here freely, it seems plausible that
+;;; small changes to the circumstances under which this function
+;;; returns non-NIL might have subtle consequences on the compiler.
+;;; So it might be desirable to have the compiler not rely on this
+;;; function, eventually.
 (defun function-lambda-expression (fun)
   "Return (VALUES DEFINING-LAMBDA-EXPRESSION CLOSURE-P NAME), where
   DEFINING-LAMBDA-EXPRESSION is NIL if unknown, or a suitable argument
   to COMPILE otherwise, CLOSURE-P is non-NIL if the function's definition
   might have been enclosed in some non-null lexical environment, and
   NAME is some name (for debugging only) or NIL if there is no name."
-    (declare (type function fun))
-    (let* ((fun (%simple-fun-self fun))
-           (name (%fun-name fun))
-           (code (sb!di::fun-code-header fun))
-           (info (sb!kernel:%code-debug-info code)))
-      (if info
-        (let ((source (sb!c::debug-info-source info)))
-          (cond ((and (eq (sb!c::debug-source-from source) :lisp)
-                      (eq (sb!c::debug-source-function source) fun))
-                 (values (svref (sb!c::debug-source-name source) 0)
-                         nil
-                         name))
-                ((legal-fun-name-p name)
-                 (let ((exp (fun-name-inline-expansion name)))
-                   (values exp (not exp) name)))
-                (t
-                 (values nil t name))))
-        (values nil t name))))
+  (declare (type function fun))
+  (etypecase fun
+    #!+sb-eval
+    (sb!eval:interpreted-function
+     (let ((name (sb!eval:interpreted-function-name fun))
+           (lambda-list (sb!eval:interpreted-function-lambda-list fun))
+           (body (sb!eval:interpreted-function-body fun)))
+       (values `(lambda ,lambda-list ,@body)
+               t name)))
+    (function
+     (let* ((fun (%simple-fun-self (%fun-fun fun)))
+            (name (%fun-name fun))
+            (code (sb!di::fun-code-header fun))
+            (info (sb!kernel:%code-debug-info code)))
+       (if info
+           (let ((source (sb!c::debug-info-source info)))
+             (cond ((and (sb!c::debug-source-form source)
+                         (eq (sb!c::debug-source-function source) fun))
+                    (values (sb!c::debug-source-form source)
+                            nil
+                            name))
+                   ((legal-fun-name-p name)
+                    (let ((exp (fun-name-inline-expansion name)))
+                      (values exp (not exp) name)))
+                   (t
+                    (values nil t name))))
+           (values nil t name))))))
 
 (defun closurep (object)
   (= sb!vm:closure-header-widetag (widetag-of object)))
@@ -57,9 +73,9 @@
 
 (defun %closure-values (object)
   (declare (function object))
-  (coerce (loop for index from 0 below (1- (get-closure-length object))
-                collect (%closure-index-ref object index))
-          'simple-vector))
+  (loop for index from 0
+     below (- (get-closure-length object) (1- sb!vm:closure-info-offset))
+     collect (%closure-index-ref object index)))
 
 (defun %fun-lambda-list (object)
   (%simple-fun-arglist (%fun-fun object)))
@@ -129,7 +145,8 @@
 (defun machine-instance ()
   #!+sb-doc
   "Return a string giving the name of the local machine."
-  (sb!unix:unix-gethostname))
+  #!+win32 (sb!win32::get-computer-name)
+  #!-win32 (sb!unix:unix-gethostname))
 
 (defvar *machine-version*)