src/pcl/slot-name.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 software originally released by Xerox
   5 ;;;; Corporation. Copyright and release statements follow. Later modifications
   6 ;;;; to the software are in the public domain and are provided with
   7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
   8 ;;;; information.
   9
  10 ;;;; copyright information from original PCL sources:
  11 ;;;;
  12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  13 ;;;; All rights reserved.
  14 ;;;;
  15 ;;;; Use and copying of this software and preparation of derivative works based
  16 ;;;; upon this software are permitted. Any distribution of this software or
  17 ;;;; derivative works must comply with all applicable United States export
  18 ;;;; control laws.
  19 ;;;;
  20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  21 ;;;; warranty about the software, its performance or its conformity to any
  22 ;;;; specification.
  23
  24 (in-package "SB-PCL")
  25 \f
  26 ;; This choice of naming structure is perhaps unfortunate, because were the
  27 ;; names 2-lists, the globaldb hack to support this would instead be
  28 ;; a natural use of the (SETF <x>) style naming that globaldb favors.
  29 ;; But this naming is documented, and changing it would be incompatible.
  30 ;; The 4-part name can be thought of as a 2-part name because
  31 ;; half of it is composed of constants:
  32 ;; (SB-PCL::SLOT-ACCESSOR :GLOBAL <foo> SB-PCL::{READER|WRITER|BOUNDP|MAKUNBOUND})
  33 ;; -> ({READER|WRITER|BOUNDP|MAKUNBOUND} <foo>)
  34 ;;
  35 ;; (but beware future maintainer: SB-PCL::BOUNDP/MAKUNBOUND are
  36 ;; symbols in the CL package so should probably not be used to
  37 ;; introduce extended function name syntax, even by SBCL the
  38 ;; implementation)
  39 (defun slot-reader-name (slot-name)
  40   (list 'slot-accessor :global slot-name 'reader))
  41
  42 (defun slot-writer-name (slot-name)
  43   (list 'slot-accessor :global slot-name 'writer))
  44
  45 (defun slot-boundp-name (slot-name)
  46   (list 'slot-accessor :global slot-name 'boundp))
  47
  48 (defun slot-makunbound-name (slot-name)
  49   (list 'slot-accessor :global slot-name 'makunbound))
  50
  51 (define-function-name-syntax slot-accessor (list)
  52   (when (= (length list) 4)
  53     (destructuring-bind (class slot rwb) (cdr list)
  54       (when (and (member rwb '(reader writer boundp makunbound))
  55                  (symbolp slot)
  56                  (symbolp class))
  57         (values t slot)))))
  58
  59 ;;; This is the object that we stick into a slot to tell us that it is
  60 ;;; unbound. It is the same as the marker for unbound symbols.
  61 ;;; There are two ways to check whether a slot is unbound:
  62 ;;;   (EQ <val> +slot-unbound+) ; ordinary object equality test
  63 ;;;   (UNBOUND-MARKER-P <val>)  ; (potentially) faster test
  64 ;;;
  65 ;;; It seems only reasonable to also export this for users, since
  66 ;;; otherwise dealing with STANDARD-INSTANCE-ACCESS becomes harder
  67 ;;; -- and slower -- than it needs to be.
  68 #-sb-xc-host (define-symbol-macro +slot-unbound+ (make-unbound-marker))
  69