X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-misc.lisp;h=05386fdb7d04600b3478046093bd35f7e3e07667;hb=51d5b9c8ca4e5e3d302e8ebf49042ac49b92c4e4;hp=a021148b4ace68ad0b187667c6526e64fff84326;hpb=e8b69b1dd5564a4237b1bdc1060820c3b820cde2;p=sbcl.git

diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp
index a021148..05386fd 100644
--- a/src/code/target-misc.lisp
+++ b/src/code/target-misc.lisp
@@ -29,44 +29,55 @@
 	   (code (sb!di::fun-code-header fun))
 	   (info (sb!kernel:%code-debug-info code)))
       (if info
-        (let ((source (first (sb!c::compiled-debug-info-source info))))
+        (let ((source (sb!c::debug-info-source info)))
           (cond ((and (eq (sb!c::debug-source-from source) :lisp)
-                      (eq (sb!c::debug-source-info source) fun))
-                 (values (second (svref (sb!c::debug-source-name source) 0))
+                      (eq (sb!c::debug-source-function source) fun))
+                 (values (svref (sb!c::debug-source-name source) 0)
                          nil
 			 name))
-                ((stringp name)
-                 (values nil t name))
-                (t
+                ((legal-fun-name-p name)
                  (let ((exp (fun-name-inline-expansion name)))
-                   (if exp
-                       (values exp nil name)
-                       (values nil t 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)))
+
+(defun %fun-fun (function)
+  (declare (function function))
+  (case (widetag-of function)
+    (#.sb!vm:simple-fun-header-widetag 
+     function)
+    (#.sb!vm:closure-header-widetag 
+     (%closure-fun function))
+    (#.sb!vm:funcallable-instance-header-widetag
+     (funcallable-instance-fun function))))
+
+(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))
+
+(defun %fun-lambda-list (object)
+  (%simple-fun-arglist (%fun-fun object)))
+
 ;;; a SETFable function to return the associated debug name for FUN
 ;;; (i.e., the third value returned from CL:FUNCTION-LAMBDA-EXPRESSION),
 ;;; or NIL if there's none
-(defun %fun-name (fun)
-  (case (widetag-of fun)
-    (#.sb!vm:closure-header-widetag
-     (%simple-fun-name (%closure-fun fun)))
-    ((#.sb!vm:simple-fun-header-widetag
-      #.sb!vm:closure-fun-header-widetag)
-     ;; KLUDGE: The pun that %SIMPLE-FUN-NAME is used for closure
-     ;; functions is left over from CMU CL (modulo various renaming
-     ;; that's gone on since the fork).
-     (%simple-fun-name fun))
-    (#.sb!vm:funcallable-instance-header-widetag
-     (%simple-fun-name
-      (funcallable-instance-fun fun)))))
+(defun %fun-name (function)
+  (%simple-fun-name (%fun-fun function)))
+
+(defun %fun-type (function)
+  (%simple-fun-type (%fun-fun function)))
 
 (defun (setf %fun-name) (new-name fun)
   (aver nil) ; since this is unsafe 'til bug 137 is fixed
   (let ((widetag (widetag-of fun)))
     (case widetag
-      ((#.sb!vm:simple-fun-header-widetag
-	#.sb!vm:closure-fun-header-widetag)
+      (#.sb!vm:simple-fun-header-widetag
        ;; KLUDGE: The pun that %SIMPLE-FUN-NAME is used for closure
        ;; functions is left over from CMU CL (modulo various renaming
        ;; that's gone on since the fork).
@@ -120,6 +131,16 @@
   "Return a string giving the name of the local machine."
   (sb!unix:unix-gethostname))
 
+(defvar *machine-version*)
+
+(defun machine-version ()
+  #!+sb-doc
+  "Return a string describing the version of the computer hardware we
+are running on, or NIL if we can't find any useful information."
+  (unless (boundp '*machine-version*)
+    (setf *machine-version* (get-machine-version)))
+  *machine-version*)
+  
 ;;; FIXME: Don't forget to set these in a sample site-init file.
 ;;; FIXME: Perhaps the functions could be SETFable instead of having the
 ;;; interface be through special variables? As far as I can tell
@@ -140,6 +161,24 @@
   "Return a string with the long form of the site name, or NIL if not known."
   *long-site-name*)
 
+;;;; ED
+(defvar *ed-functions* nil
+  "See function documentation for ED.")
+
+(defun ed (&optional x)
+  "Starts the editor (on a file or a function if named).  Functions
+from the list *ED-FUNCTIONS* are called in order with X as an argument
+until one of them returns non-NIL; these functions are responsible for
+signalling a FILE-ERROR to indicate failure to perform an operation on
+the file system."
+  (dolist (fun *ed-functions*
+	   (error 'extension-failure
+		  :format-control "Don't know how to ~S ~A"
+		  :format-arguments (list 'ed x)
+		  :references (list '(:sbcl :variable *ed-functions*))))
+    (when (funcall fun x)
+      (return t))))
+
 ;;;; dribble stuff
 
 ;;; Each time we start dribbling to a new stream, we put it in
@@ -194,3 +233,16 @@
 
 (defun %byte-blt (src src-start dst dst-start dst-end)
   (%byte-blt src src-start dst dst-start dst-end))
+
+;;;; some *LOAD-FOO* variables
+
+(defvar *load-print* nil
+  #!+sb-doc
+  "the default for the :PRINT argument to LOAD")
+
+(defvar *load-verbose* nil
+  ;; Note that CMU CL's default for this was T, and ANSI says it's
+  ;; implementation-dependent. We choose NIL on the theory that it's
+  ;; a nicer default behavior for Unix programs.
+  #!+sb-doc
+  "the default for the :VERBOSE argument to LOAD")