;;;; files for more information.
(in-package "SB!IMPL")
-\f
-;;;; function names and documentation
-
-;;;; the ANSI interface to function names (and to other stuff too)
-(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))))
-
-(defun closurep (object)
- (= sb!vm:closure-header-widetag (widetag-of object)))
+;;;; Generalizing over SIMPLE-FUN, CLOSURE, and FUNCALLABLE-INSTANCEs
+;;; Underlying SIMPLE-FUN
(defun %fun-fun (function)
(declare (function function))
- (case (widetag-of function)
- (#.sb!vm:simple-fun-header-widetag
+ (typecase function
+ (simple-fun
function)
- (#.sb!vm:closure-header-widetag
+ (closure
(%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))
+ (funcallable-instance
+ (%fun-fun (funcallable-instance-fun function)))))
+
+(defun %fun-lambda-list (function)
+ (typecase function
+ #!+sb-eval
+ (sb!eval:interpreted-function
+ (sb!eval:interpreted-function-debug-lambda-list function))
+ (t
+ (%simple-fun-arglist (%fun-fun function)))))
+
+(defun (setf %fun-lambda-list) (new-value function)
+ (typecase function
+ #!+sb-eval
+ (sb!eval:interpreted-function
+ (setf (sb!eval:interpreted-function-debug-lambda-list function) new-value))
+ ;; FIXME: Eliding general funcallable-instances for now.
+ ((or simple-fun closure)
+ (setf (%simple-fun-arglist (%fun-fun function)) new-value)))
+ new-value)
-(defun %fun-lambda-list (object)
- (%simple-fun-arglist (%fun-fun object)))
+(defun %fun-type (function)
+ (%simple-fun-type (%fun-fun function)))
;;; 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 (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
- ;; 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).
- (setf (%simple-fun-name fun) new-name))
- (#.sb!vm:closure-header-widetag
- ;; FIXME: It'd be nice to be able to set %FUN-NAME here on
- ;; per-closure basis. Instead, we are still using the CMU CL
- ;; approach of closures being named after their closure
- ;; function, which doesn't work right e.g. for structure
- ;; accessors, and might not be quite right for DEFUN
- ;; in a non-null lexical environment either.
- ;; 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.
- ;;
- ;; Meanwhile, users might encounter this problem by doing DEFUN
- ;; in a non-null lexical environment, so we try to give a
- ;; reasonably meaningful user-level "error" message (but only
- ;; as a warning because this is optional debugging
- ;; functionality anyway, not some hard ANSI requirement).
- (warn "can't set name for closure, leaving name unchanged"))
- (t
- ;; The other function subtype names are also un-settable
- ;; but this problem seems less likely to be tickled by
- ;; 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))))
- new-name)
-
-(defun %fun-doc (x)
- ;; FIXME: This business of going through %FUN-NAME and then globaldb
- ;; is the way CMU CL did it, but it doesn't really seem right.
- ;; When/if weak hash tables become supported again, using a weak
- ;; hash table to maintain the object/documentation association would
- ;; probably be better.
- (let ((name (%fun-name x)))
- (when (and name (typep name '(or symbol cons)))
- (values (info :function :documentation name)))))
+ (typecase function
+ #!+sb-eval
+ (sb!eval:interpreted-function
+ (sb!eval:interpreted-function-debug-name function))
+ (t
+ (%simple-fun-name (%fun-fun function)))))
+
+(defun (setf %fun-name) (new-value function)
+ (typecase function
+ #!+sb-eval
+ (sb!eval:interpreted-function
+ (setf (sb!eval:interpreted-function-debug-name function) new-value))
+ ;; FIXME: Eliding general funcallable-instances for now.
+ ((or simple-fun closure)
+ (setf (%simple-fun-name (%fun-fun function)) new-value)))
+ new-value)
+
+(defun %fun-doc (function)
+ (typecase function
+ #!+sb-eval
+ (sb!eval:interpreted-function
+ (sb!eval:interpreted-function-documentation function))
+ (t
+ (%simple-fun-doc (%fun-fun function)))))
+
+(defun (setf %fun-doc) (new-value function)
+ (declare (type (or null string) new-value))
+ (typecase function
+ #!+sb-eval
+ (sb!eval:interpreted-function
+ (setf (sb!eval:interpreted-function-documentation function) new-value))
+ ((or simple-fun closure)
+ (setf (%simple-fun-doc (%fun-fun function)) new-value)))
+ new-value)
\f
;;; various environment inquiries
-(defvar *features* '#.sb-cold:*shebang-features*
+(defvar *features*
+ '#.(sort (copy-list sb-cold:*shebang-features*) #'string<)
#!+sb-doc
"a list of symbols that describe features provided by the
implementation")
(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)
projects / sbcl.git / blobdiff