src/code/target-misc.lisp

   1 ;;;; Environment query functions, DOCUMENTATION and DRIBBLE.
   2 ;;;;
   3 ;;;; FIXME: If there are exactly three things in here, it could be
   4 ;;;; exactly three files named e.g. equery.lisp, doc.lisp, and dribble.lisp.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 (in-package "SB!IMPL")
  16 ;;;; Generalizing over SIMPLE-FUN, CLOSURE, and FUNCALLABLE-INSTANCEs
  17
  18 ;;; Underlying SIMPLE-FUN
  19 (defun %fun-fun (function)
  20   (declare (function function))
  21   (declare (optimize (sb!c::recognize-self-calls 3))) ; not working - why?
  22   ;; It's too bad that TYPECASE isn't able to generate equivalent code.
  23   (case (fun-subtype function)
  24     (#.sb!vm:simple-fun-header-widetag
  25      function)
  26     (#.sb!vm:closure-header-widetag
  27      (%closure-fun function))
  28     (#.sb!vm:funcallable-instance-header-widetag
  29      ;; %FUNCALLABLE-INSTANCE-FUNCTION is not known to return a FUNCTION.
  30      ;; Is that right? Shouldn't we always initialize to something
  31      ;; that is a function, such as an error-signaling trampoline?
  32      (%fun-fun (%funcallable-instance-function function)))))
  33
  34 (defun %fun-lambda-list (function)
  35   (typecase function
  36     #!+sb-eval
  37     (sb!eval:interpreted-function
  38      (sb!eval:interpreted-function-debug-lambda-list function))
  39     (t
  40      (%simple-fun-arglist (%fun-fun function)))))
  41
  42 (defun (setf %fun-lambda-list) (new-value function)
  43   (typecase function
  44     #!+sb-eval
  45     (sb!eval:interpreted-function
  46      (setf (sb!eval:interpreted-function-debug-lambda-list function) new-value))
  47     ;; FIXME: Eliding general funcallable-instances for now.
  48     ((or simple-fun closure)
  49      (setf (%simple-fun-arglist (%fun-fun function)) new-value)))
  50   new-value)
  51
  52 (defun %fun-type (function)
  53   (%simple-fun-type (%fun-fun function)))
  54
  55 ;;; a SETFable function to return the associated debug name for FUN
  56 ;;; (i.e., the third value returned from CL:FUNCTION-LAMBDA-EXPRESSION),
  57 ;;; or NIL if there's none
  58 (defun %fun-name (function)
  59   (typecase function
  60     #!+sb-eval
  61     (sb!eval:interpreted-function
  62      (sb!eval:interpreted-function-debug-name function))
  63     (t
  64      (%simple-fun-name (%fun-fun function)))))
  65
  66 (defun (setf %fun-name) (new-value function)
  67   (typecase function
  68     #!+sb-eval
  69     (sb!eval:interpreted-function
  70      (setf (sb!eval:interpreted-function-debug-name function) new-value))
  71     ;; FIXME: Eliding general funcallable-instances for now.
  72     ((or simple-fun closure)
  73      (setf (%simple-fun-name (%fun-fun function)) new-value)))
  74   new-value)
  75
  76 (defun %fun-doc (function)
  77   (typecase function
  78     #!+sb-eval
  79     (sb!eval:interpreted-function
  80      (sb!eval:interpreted-function-documentation function))
  81     (t
  82      (%simple-fun-doc (%fun-fun function)))))
  83
  84 (defun (setf %fun-doc) (new-value function)
  85   (declare (type (or null string) new-value))
  86   (typecase function
  87     #!+sb-eval
  88     (sb!eval:interpreted-function
  89      (setf (sb!eval:interpreted-function-documentation function) new-value))
  90     ((or simple-fun closure)
  91      (setf (%simple-fun-doc (%fun-fun function)) new-value)))
  92   new-value)
  93 \f
  94 ;;; various environment inquiries
  95
  96 (defvar *features*
  97   '#.(sort (copy-list sb-cold:*shebang-features*) #'string<)
  98   #!+sb-doc
  99   "a list of symbols that describe features provided by the
 100    implementation")
 101
 102 (defun machine-instance ()
 103   #!+sb-doc
 104   "Return a string giving the name of the local machine."
 105   #!+win32 (sb!win32::get-computer-name)
 106   #!-win32 (sb!unix:unix-gethostname))
 107
 108 (defvar *machine-version*)
 109
 110 (defun machine-version ()
 111   #!+sb-doc
 112   "Return a string describing the version of the computer hardware we
 113 are running on, or NIL if we can't find any useful information."
 114   (unless (boundp '*machine-version*)
 115     (setf *machine-version* (get-machine-version)))
 116   *machine-version*)
 117
 118 ;;; FIXME: Don't forget to set these in a sample site-init file.
 119 ;;; FIXME: Perhaps the functions could be SETFable instead of having the
 120 ;;; interface be through special variables? As far as I can tell
 121 ;;; from ANSI 11.1.2.1.1 "Constraints on the COMMON-LISP Package
 122 ;;; for Conforming Implementations" it is kosher to add a SETF function for
 123 ;;; a symbol in COMMON-LISP..
 124 (defvar *short-site-name* nil
 125   #!+sb-doc
 126   "The value of SHORT-SITE-NAME.")
 127 (defvar *long-site-name* nil
 128   #!+sb-doc "the value of LONG-SITE-NAME")
 129 (defun short-site-name ()
 130   #!+sb-doc
 131   "Return a string with the abbreviated site name, or NIL if not known."
 132   *short-site-name*)
 133 (defun long-site-name ()
 134   #!+sb-doc
 135   "Return a string with the long form of the site name, or NIL if not known."
 136   *long-site-name*)
 137 \f
 138 ;;;; ED
 139 (defvar *ed-functions* nil
 140   #!+sb-doc
 141   "See function documentation for ED.")
 142
 143 (defun ed (&optional x)
 144   #!+sb-doc
 145   "Starts the editor (on a file or a function if named).  Functions
 146 from the list *ED-FUNCTIONS* are called in order with X as an argument
 147 until one of them returns non-NIL; these functions are responsible for
 148 signalling a FILE-ERROR to indicate failure to perform an operation on
 149 the file system."
 150   (dolist (fun *ed-functions*
 151            (error 'extension-failure
 152                   :format-control "Don't know how to ~S ~A"
 153                   :format-arguments (list 'ed x)
 154                   :references (list '(:sbcl :variable *ed-functions*))))
 155     (when (funcall fun x)
 156       (return t))))
 157 \f
 158 ;;;; dribble stuff
 159
 160 ;;; Each time we start dribbling to a new stream, we put it in
 161 ;;; *DRIBBLE-STREAM*, and push a list of *DRIBBLE-STREAM*, *STANDARD-INPUT*,
 162 ;;; *STANDARD-OUTPUT* and *ERROR-OUTPUT* in *PREVIOUS-DRIBBLE-STREAMS*.
 163 ;;; *STANDARD-OUTPUT* and *ERROR-OUTPUT* is changed to a broadcast stream that
 164 ;;; broadcasts to *DRIBBLE-STREAM* and to the old values of the variables.
 165 ;;; *STANDARD-INPUT* is changed to an echo stream that echos input from the old
 166 ;;; value of standard input to *DRIBBLE-STREAM*.
 167 ;;;
 168 ;;; When dribble is called with no arguments, *DRIBBLE-STREAM* is closed,
 169 ;;; and the values of *DRIBBLE-STREAM*, *STANDARD-INPUT*, and
 170 ;;; *STANDARD-OUTPUT* are popped from *PREVIOUS-DRIBBLE-STREAMS*.
 171
 172 (defvar *previous-dribble-streams* nil)
 173 (defvar *dribble-stream* nil)
 174
 175 (defun dribble (&optional pathname &key (if-exists :append))
 176   #!+sb-doc
 177   "With a file name as an argument, dribble opens the file and sends a
 178   record of further I/O to that file. Without an argument, it closes
 179   the dribble file, and quits logging."
 180   (cond (pathname
 181          (let* ((new-dribble-stream
 182                  (open pathname
 183                        :direction :output
 184                        :if-exists if-exists
 185                        :if-does-not-exist :create))
 186                 (new-standard-output
 187                  (make-broadcast-stream *standard-output* new-dribble-stream))
 188                 (new-error-output
 189                  (make-broadcast-stream *error-output* new-dribble-stream))
 190                 (new-standard-input
 191                  (make-echo-stream *standard-input* new-dribble-stream)))
 192            (push (list *dribble-stream* *standard-input* *standard-output*
 193                        *error-output*)
 194                  *previous-dribble-streams*)
 195            (setf *dribble-stream* new-dribble-stream)
 196            (setf *standard-input* new-standard-input)
 197            (setf *standard-output* new-standard-output)
 198            (setf *error-output* new-error-output)))
 199         ((null *dribble-stream*)
 200          (error "not currently dribbling"))
 201         (t
 202          (let ((old-streams (pop *previous-dribble-streams*)))
 203            (close *dribble-stream*)
 204            (setf *dribble-stream* (first old-streams))
 205            (setf *standard-input* (second old-streams))
 206            (setf *standard-output* (third old-streams))
 207            (setf *error-output* (fourth old-streams)))))
 208   (values))
 209
 210 (defun %byte-blt (src src-start dst dst-start dst-end)
 211   (%byte-blt src src-start dst dst-start dst-end))
 212
 213 ;;;; some *LOAD-FOO* variables
 214
 215 (defvar *load-print* nil
 216   #!+sb-doc
 217   "the default for the :PRINT argument to LOAD")
 218
 219 (defvar *load-verbose* nil
 220   ;; Note that CMU CL's default for this was T, and ANSI says it's
 221   ;; implementation-dependent. We choose NIL on the theory that it's
 222   ;; a nicer default behavior for Unix programs.
 223   #!+sb-doc
 224   "the default for the :VERBOSE argument to LOAD")