src/code/late-extensions.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB!EXT")
  11
  12 (file-comment
  13   "$Header$")
  14
  15 (defun featurep (x)
  16   #!+sb-doc
  17   "If X is an atom, see whether it is present in *FEATURES*. Also
  18   handle arbitrary combinations of atoms using NOT, AND, OR."
  19   (if (consp x)
  20     (case (car x)
  21       ((:not not)
  22        (if (cddr x)
  23          (error "too many subexpressions in feature expression: ~S" x)
  24          (not (featurep (cadr x)))))
  25       ((:and and) (every #'featurep (cdr x)))
  26       ((:or or) (some #'featurep (cdr x)))
  27       (t
  28        (error "unknown operator in feature expression: ~S." x)))
  29     (not (null (memq x *features*)))))
  30
  31 ;;; KLUDGE: This is a wrapper around stale code for working with floating point
  32 ;;; infinities. I believe that I will eventually eliminate floating point
  33 ;;; infinities from the code, since they're a pain to cross-compile, since they
  34 ;;; significantly increase the number of conditions which need to be tested in
  35 ;;; numeric functions, and since the benefits which they provide (which are
  36 ;;; admittedly significant) are unfortunately not portable. I haven't actually
  37 ;;; done the dirty deed yet, though, and until then, I've wrapped various
  38 ;;; infinity-returning forms in this macro. -- WHN 1999
  39 (defmacro infinite (x)
  40   (declare (ignorable x))
  41   #!-sb-infinities '(error 'floating-point-overflow)
  42   #!+sb-infinities x)
  43
  44 ;;; Given a list of keyword substitutions `(,OLD ,NEW), and a
  45 ;;; keyword-argument-list-style list of alternating keywords and arbitrary
  46 ;;; values, return a new keyword-argument-list-style list with all
  47 ;;; substitutions applied to it.
  48 ;;;
  49 ;;; Note: If efficiency mattered, we could do less consing. (But if efficiency
  50 ;;; mattered, why would we be using keyword arguments at all, much less
  51 ;;; renaming keyword arguments?)
  52 ;;;
  53 ;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201
  54 (defun rename-keyword-args (rename-list keyword-args)
  55   (declare (type list rename-list keyword-args))
  56   ;; Walk through RENAME-LIST modifying RESULT as per each element in
  57   ;; RENAME-LIST.
  58   (do ((result (copy-list keyword-args))) ; may be modified below
  59       ((null rename-list) result)
  60     (destructuring-bind (old new) (pop rename-list)
  61       (declare (type keyword old new))
  62       ;; Walk through RESULT renaming any OLD keyword argument to NEW.
  63       (do ((in-result result (cddr in-result)))
  64           ((null in-result))
  65         (declare (type list in-result))
  66         (when (eq (car in-result) old)
  67           (setf (car in-result) new))))))
  68
  69 ;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the
  70 ;;; other ANSI input functions, is defined to communicate end of file
  71 ;;; status with its return value, not by signalling. This is not the
  72 ;;; behavior we usually want. This is a wrapper which give the
  73 ;;; behavior we usually want, causing READ-SEQUENCE to communicate
  74 ;;; end-of-file status by signalling.
  75 (defun read-sequence-or-die (sequence stream &key start end)
  76   ;; implementation using READ-SEQUENCE
  77   #-no-ansi-read-sequence
  78   (let ((read-end (read-sequence sequence
  79                                  stream
  80                                  :start start
  81                                  :end end)))
  82     (unless (= read-end end)
  83       (error 'end-of-file :stream stream))
  84     (values))
  85   ;; workaround for broken READ-SEQUENCE
  86   #+no-ansi-read-sequence
  87   (progn
  88     (assert (<= start end))
  89     (let ((etype (stream-element-type stream)))
  90     (cond ((equal etype '(unsigned-byte 8))
  91            (do ((i start (1+ i)))
  92                ((>= i end)
  93                 (values))
  94              (setf (aref sequence i)
  95                    (read-byte stream))))
  96           (t (error "unsupported element type ~S" etype))))))