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!IMPL")
  11
  12 (defun featurep (x)
  13   #!+sb-doc
  14   "If X is an atom, see whether it is present in *FEATURES*. Also
  15   handle arbitrary combinations of atoms using NOT, AND, OR."
  16   (if (consp x)
  17     (case (car x)
  18       ((:not not)
  19        (if (cddr x)
  20          (error "too many subexpressions in feature expression: ~S" x)
  21          (not (featurep (cadr x)))))
  22       ((:and and) (every #'featurep (cdr x)))
  23       ((:or or) (some #'featurep (cdr x)))
  24       (t
  25        (error "unknown operator in feature expression: ~S." x)))
  26     (not (null (memq x *features*)))))
  27
  28 ;;; Given a list of keyword substitutions `(,OLD ,NEW), and a
  29 ;;; &KEY-argument-list-style list of alternating keywords and
  30 ;;; arbitrary values, return a new &KEY-argument-list-style list with
  31 ;;; all substitutions applied to it.
  32 ;;;
  33 ;;; Note: If efficiency mattered, we could do less consing. (But if
  34 ;;; efficiency mattered, why would we be using &KEY arguments at
  35 ;;; all, much less renaming &KEY arguments?)
  36 ;;;
  37 ;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201
  38 (defun rename-key-args (rename-list key-args)
  39   (declare (type list rename-list key-args))
  40   ;; Walk through RENAME-LIST modifying RESULT as per each element in
  41   ;; RENAME-LIST.
  42   (do ((result (copy-list key-args))) ; may be modified below
  43       ((null rename-list) result)
  44     (destructuring-bind (old new) (pop rename-list)
  45       ;; ANSI says &KEY arg names aren't necessarily KEYWORDs.
  46       (declare (type symbol old new))
  47       ;; Walk through RESULT renaming any OLD key argument to NEW.
  48       (do ((in-result result (cddr in-result)))
  49           ((null in-result))
  50         (declare (type list in-result))
  51         (when (eq (car in-result) old)
  52           (setf (car in-result) new))))))
  53
  54 ;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the
  55 ;;; other ANSI input functions, is defined to communicate end of file
  56 ;;; status with its return value, not by signalling. This is not the
  57 ;;; behavior we usually want. This is a wrapper which give the
  58 ;;; behavior we usually want, causing READ-SEQUENCE to communicate
  59 ;;; end-of-file status by signalling.
  60 (defun read-sequence-or-die (sequence stream &key start end)
  61   ;; implementation using READ-SEQUENCE
  62   #-no-ansi-read-sequence
  63   (let ((read-end (read-sequence sequence
  64                                  stream
  65                                  :start start
  66                                  :end end)))
  67     (unless (= read-end end)
  68       (error 'end-of-file :stream stream))
  69     (values))
  70   ;; workaround for broken READ-SEQUENCE
  71   #+no-ansi-read-sequence
  72   (progn
  73     (aver (<= start end))
  74     (let ((etype (stream-element-type stream)))
  75     (cond ((equal etype '(unsigned-byte 8))
  76            (do ((i start (1+ i)))
  77                ((>= i end)
  78                 (values))
  79              (setf (aref sequence i)
  80                    (read-byte stream))))
  81           (t (error "unsupported element type ~S" etype))))))