X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-misc.lisp;h=365bfaaa8c658f24b00805c98b483b58abc53217;hb=2df8da85688355b4f4f31314246483ccea364746;hp=e4c9acd9f6dda78701d62c2c09f2ac920f24f09c;hpb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;p=sbcl.git diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp index e4c9acd..365bfaa 100644 --- a/src/code/target-misc.lisp +++ b/src/code/target-misc.lisp @@ -13,33 +13,149 @@ ;;;; files for more information. (in-package "SB!IMPL") + +;;;; 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)) + (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)) + (declarations (sb!eval:interpreted-function-declarations fun)) + (body (sb!eval:interpreted-function-body fun))) + (values `(lambda ,lambda-list + ,@(when declarations `((declare ,@declarations))) + ,@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)))))) + +;;;; Generalizing over SIMPLE-FUN, CLOSURE, and FUNCALLABLE-INSTANCEs + +;;; Underlying SIMPLE-FUN +(defun %fun-fun (function) + (declare (function function)) + (typecase function + (simple-fun + function) + (closure + (%closure-fun function)) + (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) -;;; cobbled from stuff in describe.lisp. -(defun function-doc (x) - (let ((name - (case (widetag-of x) - (#.sb!vm:closure-header-widetag - (%simple-fun-name (%closure-fun x))) - ((#.sb!vm:simple-fun-header-widetag - #.sb!vm:closure-fun-header-widetag) - (%simple-fun-name x)) - (#.sb!vm:funcallable-instance-header-widetag - (%simple-fun-name - (funcallable-instance-fun x)))))) - (when (and name (typep name '(or symbol cons))) - (values (info :function :documentation name))))) +(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) + (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) + +;;; various environment inquiries (defvar *features* '#.sb-cold:*shebang-features* #!+sb-doc "a list of symbols that describe features provided by the implementation") - -;;; various environment inquiries (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*) + +(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 @@ -61,6 +177,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 @@ -84,34 +218,47 @@ 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) (%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")