;;;; 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)))
(defun %fun-fun (function)
(declare (function function))
(case (widetag-of function)
- (#.sb!vm:simple-fun-header-widetag
+ (#.sb!vm:simple-fun-header-widetag
function)
- (#.sb!vm:closure-header-widetag
+ (#.sb!vm:closure-header-widetag
(%closure-fun function))
(#.sb!vm:funcallable-instance-header-widetag
- (funcallable-instance-fun function))))
+ (%fun-fun (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))
+ (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)))
;; When/if weak hash tables become supported
;; again, it'll become easy to fix this, but for now there
;; seems to be no easy way (short of the ugly way of adding a
- ;; slot to every single closure header), so we don't.
+ ;; slot to every single closure header), so we don't.
;;
;; Meanwhile, users might encounter this problem by doing DEFUN
;; in a non-null lexical environment, so we try to give a
;; user-level code, so we can give a implementor-level
;; "error" (warning) message.
(warn "can't set function name ((~S function)=~S), leaving it unchanged"
- 'widetag-of widetag))))
+ 'widetag-of widetag))))
new-name)
(defun %fun-doc (x)
(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*)
(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
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*))))
+ (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))))
\f
record of further I/O to that file. Without an argument, it closes
the dribble file, and quits logging."
(cond (pathname
- (let* ((new-dribble-stream
- (open pathname
- :direction :output
- :if-exists if-exists
- :if-does-not-exist :create))
- (new-standard-output
- (make-broadcast-stream *standard-output* new-dribble-stream))
- (new-error-output
- (make-broadcast-stream *error-output* new-dribble-stream))
- (new-standard-input
- (make-echo-stream *standard-input* new-dribble-stream)))
- (push (list *dribble-stream* *standard-input* *standard-output*
- *error-output*)
- *previous-dribble-streams*)
- (setf *dribble-stream* new-dribble-stream)
- (setf *standard-input* new-standard-input)
- (setf *standard-output* new-standard-output)
- (setf *error-output* new-error-output)))
- ((null *dribble-stream*)
- (error "not currently dribbling"))
- (t
- (let ((old-streams (pop *previous-dribble-streams*)))
- (close *dribble-stream*)
- (setf *dribble-stream* (first old-streams))
- (setf *standard-input* (second old-streams))
- (setf *standard-output* (third old-streams))
- (setf *error-output* (fourth old-streams)))))
+ (let* ((new-dribble-stream
+ (open pathname
+ :direction :output
+ :if-exists if-exists
+ :if-does-not-exist :create))
+ (new-standard-output
+ (make-broadcast-stream *standard-output* new-dribble-stream))
+ (new-error-output
+ (make-broadcast-stream *error-output* new-dribble-stream))
+ (new-standard-input
+ (make-echo-stream *standard-input* new-dribble-stream)))
+ (push (list *dribble-stream* *standard-input* *standard-output*
+ *error-output*)
+ *previous-dribble-streams*)
+ (setf *dribble-stream* new-dribble-stream)
+ (setf *standard-input* new-standard-input)
+ (setf *standard-output* new-standard-output)
+ (setf *error-output* new-error-output)))
+ ((null *dribble-stream*)
+ (error "not currently dribbling"))
+ (t
+ (let ((old-streams (pop *previous-dribble-streams*)))
+ (close *dribble-stream*)
+ (setf *dribble-stream* (first old-streams))
+ (setf *standard-input* (second old-streams))
+ (setf *standard-output* (third old-streams))
+ (setf *error-output* (fourth old-streams)))))
(values))
(defun %byte-blt (src src-start dst dst-start dst-end)