src/code/late-extensions.lisp

   1 ;;;; various extensions (including SB-INT "internal extensions")
   2 ;;;; available both in the cross-compilation host Lisp and in the
   3 ;;;; target SBCL, but which can't be defined on the target until until
   4 ;;;; some significant amount of machinery (e.g. error-handling) is
   5 ;;;; defined
   6
   7 ;;;; This software is part of the SBCL system. See the README file for
   8 ;;;; more information.
   9 ;;;;
  10 ;;;; This software is derived from the CMU CL system, which was
  11 ;;;; written at Carnegie Mellon University and released into the
  12 ;;;; public domain. The software is in the public domain and is
  13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  14 ;;;; files for more information.
  15
  16 (in-package "SB!IMPL")
  17
  18 ;;; Is X a list for which LENGTH is meaningful, i.e. a list which is
  19 ;;; not improper and which is not circular?
  20 (defun list-with-length-p (x)
  21   (values (ignore-errors (list-length x))))
  22
  23 ;;; not used in 0.7.8, but possibly useful for defensive programming
  24 ;;; in e.g. (COERCE ... 'VECTOR)
  25 ;;;(defun list-length-or-die (x)
  26 ;;;  (or (list-length x)
  27 ;;;      ;; not clear how to do this best:
  28 ;;;      ;;   * Should this be a TYPE-ERROR? Colloquially that'd make
  29 ;;;      ;;     lots of sense, but since I'm not sure how to express
  30 ;;;      ;;     "noncircular list" as a Lisp type expression, coding
  31 ;;;      ;;     it seems awkward.
  32 ;;;      ;;   * Should the ERROR object include the offending value?
  33 ;;;      ;;     Ordinarily that's helpful, but if the user doesn't have
  34 ;;;      ;;     his printer set up to deal with cyclicity, we might not
  35 ;;;      ;;     be doing him a favor by printing the object here.
  36 ;;;      ;; -- WHN 2002-10-19
  37 ;;;      (error "can't calculate length of cyclic list")))
  38
  39 ;;; This is used in constructing arg lists for debugger printing,
  40 ;;; and when needing to print unbound slots in PCL.
  41 (defstruct (unprintable-object
  42             (:constructor make-unprintable-object (string))
  43             (:print-object (lambda (x s)
  44                              (print-unreadable-object (x s)
  45                                (write-string (unprintable-object-string x) s))))
  46             (:copier nil))
  47   string)
  48
  49 ;;; Used internally, but it would be nice to provide something
  50 ;;; like this for users as well.
  51 #!+sb-thread
  52 (defmacro define-structure-slot-compare-and-swap
  53     (name &key structure slot)
  54   (let* ((dd (find-defstruct-description structure t))
  55          (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
  56          (type (when slotd (dsd-type slotd)))
  57          (index (when slotd (dsd-index slotd))))
  58     (unless index
  59       (error "Slot ~S not found in ~S." slot structure))
  60     (unless (eq t (dsd-raw-type slotd))
  61       (error "Cannot define compare-and-swap on a raw slot."))
  62     (when (dsd-read-only slotd)
  63       (error "Cannot define compare-and-swap on a read-only slot."))
  64     `(progn
  65        (declaim (inline ,name))
  66        (defun ,name (instance old new)
  67          (declare (type ,structure instance)
  68                   (type ,type old new))
  69          (%instance-compare-and-swap instance ,index old new)))))
  70
  71 ;;; Ditto
  72 #!+sb-thread
  73 (defmacro define-structure-slot-addressor (name &key structure slot)
  74   (let* ((dd (find-defstruct-description structure t))
  75          (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
  76          (index (when slotd (dsd-index slotd))))
  77     (unless index
  78       (error "Slot ~S not found in ~S." slot structure))
  79     `(progn
  80        (declaim (inline ,name))
  81        (defun ,name (instance)
  82          (declare (type ,structure instance) (optimize speed))
  83          (sb!ext:truly-the
  84           sb!vm:word
  85           (+ (sb!kernel:get-lisp-obj-address instance)
  86              (- (* ,(+ sb!vm:instance-slots-offset index) sb!vm:n-word-bytes)
  87                 sb!vm:instance-pointer-lowtag)))))))
  88