src/code/target-misc.lisp

   1 ;;;; Environment query functions, and DRIBBLE.
   2 ;;;;
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB-IMPL")
  14
  15 ;;; various environment inquiries
  16
  17 ;;; This is a tentative list of target features; many are removed later.
  18 ;;; :SB-XC is removed now, because it is plain wrong unless cross-compiling.
  19 (defvar *features* '#.(remove :sb-xc sb-xc:*features*)
  20   "a list of symbols that describe features provided by the
  21    implementation")
  22 (defconstant !sbcl-architecture #.(sb-cold::target-platform-keyword))
  23
  24 (defun machine-instance ()
  25   "Return a string giving the name of the local machine."
  26   #+win32 (sb-win32::get-computer-name)
  27   #-win32 (truly-the simple-string (sb-unix:unix-gethostname)))
  28
  29 (declaim (type (or null simple-string) *machine-version*))
  30 (declaim (global *machine-version*))
  31
  32 (defun machine-version ()
  33   "Return a string describing the version of the computer hardware we
  34 are running on, or NIL if we can't find any useful information."
  35   (if (boundp '*machine-version*)
  36       *machine-version*
  37       (setf *machine-version*
  38             (awhen (get-machine-version) (possibly-base-stringize it)))))
  39
  40 ;;; FIXME: Don't forget to set these in a sample site-init file.
  41 ;;; FIXME: Perhaps the functions could be SETFable instead of having the
  42 ;;; interface be through special variables? As far as I can tell
  43 ;;; from ANSI 11.1.2.1.1 "Constraints on the COMMON-LISP Package
  44 ;;; for Conforming Implementations" it is kosher to add a SETF function for
  45 ;;; a symbol in COMMON-LISP..
  46 (declaim (type (or null simple-string) *short-site-name* *long-site-name*))
  47 (define-load-time-global *short-site-name* nil
  48   "The value of SHORT-SITE-NAME.")
  49 (define-load-time-global *long-site-name* nil
  50   "The value of LONG-SITE-NAME.")
  51 (defun short-site-name ()
  52   "Return a string with the abbreviated site name, or NIL if not known."
  53   *short-site-name*)
  54 (defun long-site-name ()
  55   "Return a string with the long form of the site name, or NIL if not known."
  56   *long-site-name*)
  57 \f
  58 ;;;; ED
  59 (declaim (type list *ed-functions*))
  60 (defvar *ed-functions* '()
  61   "See function documentation for ED.")
  62
  63 (defun ed (&optional x)
  64   "Starts the editor (on a file or a function if named).  Functions
  65 from the list *ED-FUNCTIONS* are called in order with X as an argument
  66 until one of them returns non-NIL; these functions are responsible for
  67 signalling a FILE-ERROR to indicate failure to perform an operation on
  68 the file system."
  69   (dolist (fun *ed-functions*
  70            (error 'extension-failure
  71                   :format-control "Don't know how to ~S ~A"
  72                   :format-arguments (list 'ed x)
  73                   :references '((:sbcl :variable *ed-functions*))))
  74     (when (funcall fun x)
  75       (return t))))
  76 \f
  77 ;;;; dribble stuff
  78
  79 ;;; Each time we start dribbling to a new stream, we put it in
  80 ;;; *DRIBBLE-STREAM*, and push a list of *DRIBBLE-STREAM*, *STANDARD-INPUT*,
  81 ;;; *STANDARD-OUTPUT* and *ERROR-OUTPUT* in *PREVIOUS-DRIBBLE-STREAMS*.
  82 ;;; *STANDARD-OUTPUT* and *ERROR-OUTPUT* is changed to a broadcast stream that
  83 ;;; broadcasts to *DRIBBLE-STREAM* and to the old values of the variables.
  84 ;;; *STANDARD-INPUT* is changed to an echo stream that echos input from the old
  85 ;;; value of standard input to *DRIBBLE-STREAM*.
  86 ;;;
  87 ;;; When dribble is called with no arguments, *DRIBBLE-STREAM* is closed,
  88 ;;; and the values of *DRIBBLE-STREAM*, *STANDARD-INPUT*, and
  89 ;;; *STANDARD-OUTPUT* are popped from *PREVIOUS-DRIBBLE-STREAMS*.
  90
  91 (defvar *previous-dribble-streams* '())
  92 (defvar *dribble-stream* nil)
  93
  94 (defun dribble (&optional pathname &key (if-exists :append))
  95   "With a file name as an argument, dribble opens the file and sends a
  96   record of further I/O to that file. Without an argument, it closes
  97   the dribble file, and quits logging."
  98   (flet ((install-streams (dribble input output error)
  99            (setf *dribble-stream* dribble
 100                  *standard-input* input
 101                  *standard-output* output
 102                  *error-output* error)))
 103     (cond (pathname
 104            (push (list *dribble-stream* *standard-input* *standard-output*
 105                        *error-output*)
 106                  *previous-dribble-streams*)
 107            (let ((new-dribble (open pathname
 108                                     :direction :output
 109                                     :if-exists if-exists
 110                                     :if-does-not-exist :create)))
 111              (install-streams
 112               new-dribble
 113               (make-echo-stream *standard-input* new-dribble)
 114               (make-broadcast-stream *standard-output* new-dribble)
 115               (make-broadcast-stream *error-output* new-dribble))))
 116           ((null *dribble-stream*)
 117            (error "not currently dribbling"))
 118           (t
 119            (close *dribble-stream*)
 120            (apply #'install-streams (pop *previous-dribble-streams*)))))
 121   (values))
 122 \f
 123 ;;;; DEFmumble helpers
 124
 125 (defun %defglobal (name value source-location &optional (doc nil docp))
 126   (%compiler-defglobal name :always-bound
 127                        (not (unbound-marker-p value)) value)
 128   (when docp
 129     (setf (documentation name 'variable) doc))
 130   (when source-location
 131     (setf (info :source-location :variable name) source-location))
 132   name)
 133
 134 (defun %defparameter (var val source-location &optional (doc nil docp))
 135   (%compiler-defvar var)
 136   (set var val)
 137   (when docp
 138     (setf (documentation var 'variable) doc))
 139   (when source-location
 140     (setf (info :source-location :variable var) source-location))
 141   var)
 142
 143 (defun %defvar (var source-location &optional (val nil valp) (doc nil docp))
 144   (%compiler-defvar var)
 145   (when (and valp
 146              (not (boundp var)))
 147     (set var val))
 148   (when docp
 149     (setf (documentation var 'variable) doc))
 150   (when source-location
 151     (setf (info :source-location :variable var) source-location))
 152   var)
 153
 154 (defun %defun (name def &optional inline-lambda extra-info)
 155   (declare (type function def))
 156   ;; should've been checked by DEFMACRO DEFUN
 157   (aver (legal-fun-name-p name))
 158   ;; If a warning handler decides to disallow this redefinition
 159   ;; by nonlocally exiting, then we'll skip the rest of this stuff.
 160   (when (and (fboundp name)
 161              *type-system-initialized*)
 162     (handler-bind (((satisfies sb-c::handle-condition-p)
 163                      'sb-c::handle-condition-handler))
 164       (warn 'redefinition-with-defun :name name :new-function def)))
 165   (sb-c:%compiler-defun name nil inline-lambda extra-info)
 166   (setf (fdefinition name) def)
 167   ;; %COMPILER-DEFUN doesn't do this except at compile-time, when it
 168   ;; also checks package locks. By doing this here we let (SETF
 169   ;; FDEFINITION) do the load-time package lock checking before
 170   ;; we frob any existing inline expansions.
 171   (sb-c::%set-inline-expansion name nil inline-lambda extra-info)
 172   (sb-c::note-name-defined name :function)
 173   name)
 174
 175 (macrolet
 176     ((cast-it ()
 177        `(when s
 178           #-sb-unicode
 179           (if (and (simple-base-string-p s) (ok-space))
 180               s
 181               (replace (make-string (length s)) s))
 182           #+sb-unicode
 183           ;; whether a copy is needed depends both on contents and simplicity
 184           (let* ((base-p (base-string-p s))
 185                  (recast (and (not base-p) (every #'base-char-p s))))
 186             (if (and (simple-string-p s) (not recast) (ok-space))
 187                 s
 188                 (let ((n (length s)))
 189                   ;; I think this could be done with a single allocator
 190                   ;; and a length calculation. I don't care to do that.
 191                   (replace (if (or base-p recast)
 192                                (make-string n :element-type 'base-char)
 193                                (make-string n))
 194                            s)))))))
 195 ;;; Ensure basicness if possible, and simplicity always
 196   (defun possibly-base-stringize (s)
 197     (macrolet ((ok-space () 't))
 198       (cast-it)))
 199 ;;; As above but copy dynamic-extent or other off-heap lisp strings
 200   (defun possibly-base-stringize-to-heap (s)
 201     (declare (sb-c::tlab :system))
 202     (macrolet ((ok-space () '(or (dynamic-space-obj-p s) (read-only-space-obj-p s))))
 203       (cast-it)))
 204   ) ; end MACROLET
 205
 206 (in-package "SB-C")
 207
 208 (defun split-version-string (string)
 209   (loop with subversion and start = 0
 210         with end = (length string)
 211         when (setf (values subversion start)
 212                    (parse-integer string :start start :junk-allowed t))
 213         collect it
 214         while (and subversion
 215                    (< start end)
 216                    (char= (char string start) #\.))
 217         do (incf start)))
 218
 219 (defun version>= (x y)
 220   (unless (or x y)
 221     (return-from version>= t))
 222   (let ((head-x (or (first x) 0))
 223         (head-y (or (first y) 0)))
 224     (or (> head-x head-y)
 225         (and (= head-x head-y)
 226              (version>= (rest x) (rest y))))))
 227
 228 (defun assert-version->= (&rest subversions)
 229   "Asserts that the current SBCL is of version equal to or greater than
 230 the version specified in the arguments.  A continuable error is signaled
 231 otherwise.
 232
 233 The arguments specify a sequence of subversion numbers in big endian order.
 234 They are compared lexicographically with the runtime version, and versions
 235 are treated as though trailed by an unbounded number of 0s.
 236
 237 For example, (assert-version->= 1 1 4) asserts that the current SBCL is
 238 version 1.1.4[.0.0...] or greater, and (assert-version->= 1) that it is
 239 version 1[.0.0...] or greater."
 240   (let ((version (split-version-string (lisp-implementation-version))))
 241     (unless (version>= version subversions)
 242       (cerror "Disregard this version requirement."
 243               "SBCL ~A is too old for this program (version ~{~A~^.~} ~
 244                or later is required)."
 245               (lisp-implementation-version)
 246               subversions))))
 247
 248 (defvar sb-pcl::*!docstrings* nil)
 249 (defun (setf documentation) (string name doc-type)
 250   (declare (type (or null string) string))
 251   (push (list string name doc-type) sb-pcl::*!docstrings*)
 252   string)