src/code/target-extensions.lisp

   1 ;;;; This file contains things for the extensions packages (SB-EXT and
   2 ;;;; also "internal extensions" SB-INT) which can't be built at
   3 ;;;; cross-compile time, and perhaps also some things which might as
   4 ;;;; well not be built at cross-compile time because they're not
   5 ;;;; needed then. Things which can't be built at cross-compile time
   6 ;;;; (e.g. because they need machinery which only exists inside SBCL's
   7 ;;;; implementation of the LISP package) do not belong in this file.
   8
   9 ;;;; This software is part of the SBCL system. See the README file for
  10 ;;;; more information.
  11 ;;;;
  12 ;;;; This software is derived from the CMU CL system, which was
  13 ;;;; written at Carnegie Mellon University and released into the
  14 ;;;; public domain. The software is in the public domain and is
  15 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  16 ;;;; files for more information.
  17
  18 (in-package "SB!IMPL")
  19 \f
  20 ;;;; variables related to saving core files
  21 ;;;;
  22 ;;;; (Most of the save-a-core functionality is defined later, in its
  23 ;;;; own file, but we'd like to have these symbols declared special
  24 ;;;; and initialized ASAP.)
  25
  26 (defvar *before-save-initializations* nil
  27   #!+sb-doc
  28   "This is a list of functions which are called before creating a saved core
  29   image. These functions are executed in the child process which has no ports,
  30   so they cannot do anything that tries to talk to the outside world.")
  31
  32 (defvar *after-save-initializations* nil
  33   #!+sb-doc
  34   "This is a list of functions which are called when a saved core image starts
  35   up. The system itself should be initialized at this point, but applications
  36   might not be.")
  37 \f
  38 ;;;; miscellaneous I/O
  39
  40 (defun skip-whitespace (&optional (stream *standard-input*))
  41   (loop (let ((char (read-char stream)))
  42           (unless (sb!impl::whitespacep char)
  43             (return (unread-char char stream))))))
  44
  45 ;;; like LISTEN, but any whitespace in the input stream will be flushed
  46 (defun listen-skip-whitespace (&optional (stream *standard-input*))
  47   (do ((char (read-char-no-hang stream nil nil nil)
  48              (read-char-no-hang stream nil nil nil)))
  49       ((null char) nil)
  50     (cond ((not (whitespace-char-p char))
  51            (unread-char char stream)
  52            (return t)))))
  53 \f
  54 ;;;; helpers for C library calls
  55
  56 ;;; Signal a SIMPLE-CONDITION/ERROR condition associated with an ANSI C
  57 ;;; errno problem, arranging for the condition's print representation
  58 ;;; to be similar to the ANSI C perror(3) style.
  59 (defun simple-perror (prefix-string
  60                       &key
  61                       (errno (get-errno))
  62                       (simple-error 'simple-error)
  63                       other-condition-args)
  64   (declare (type symbol simple-error))
  65   (aver (subtypep simple-error 'simple-condition))
  66   (aver (subtypep simple-error 'error))
  67   (apply #'error
  68          simple-error
  69          :format-control "~@<~A: ~2I~_~A~:>"
  70          :format-arguments (list prefix-string (strerror errno))
  71          other-condition-args))