src/pcl/macros.lisp

   1 ;;;; macros, global variable definitions, and other miscellaneous support stuff
   2 ;;;; used by the rest of the PCL subsystem
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6
   7 ;;;; This software is derived from software originally released by Xerox
   8 ;;;; Corporation. Copyright and release statements follow. Later modifications
   9 ;;;; to the software are in the public domain and are provided with
  10 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  11 ;;;; information.
  12
  13 ;;;; copyright information from original PCL sources:
  14 ;;;;
  15 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  16 ;;;; All rights reserved.
  17 ;;;;
  18 ;;;; Use and copying of this software and preparation of derivative works based
  19 ;;;; upon this software are permitted. Any distribution of this software or
  20 ;;;; derivative works must comply with all applicable United States export
  21 ;;;; control laws.
  22 ;;;;
  23 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  24 ;;;; warranty about the software, its performance or its conformity to any
  25 ;;;; specification.
  26
  27 (in-package "SB-PCL")
  28 \f
  29 (declaim (declaration
  30           ;; These nonstandard declarations seem to be used privately
  31           ;; within PCL itself to pass information around, so we can't
  32           ;; just delete them.
  33           %class
  34           ;; This declaration may also be used within PCL to pass
  35           ;; information around, I'm not sure. -- WHN 2000-12-30
  36           %variable-rebinding))
  37
  38 (defun get-declaration (name declarations &optional default)
  39   (dolist (d declarations default)
  40     (dolist (form (cdr d))
  41       (when (and (consp form) (eq (car form) name))
  42         (return-from get-declaration (cdr form))))))
  43
  44 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
  45   `(let ((,var nil)
  46          (.dolist-carefully. ,list))
  47      (loop (when (null .dolist-carefully.) (return nil))
  48            (if (consp .dolist-carefully.)
  49                (progn
  50                  (setq ,var (pop .dolist-carefully.))
  51                  ,@body)
  52                (,improper-list-handler)))))
  53 \f
  54 ;;;; FIND-CLASS
  55 ;;;;
  56 ;;;; This is documented in the CLOS specification.
  57
  58 (define-condition illegal-class-name-error (error)
  59   ((name :initarg :name :reader illegal-class-name-error-name))
  60   (:default-initargs :name (missing-arg))
  61   (:report (lambda (condition stream)
  62              (format stream "~@<~S is not a legal class name.~@:>"
  63                      (illegal-class-name-error-name condition)))))
  64
  65 (declaim (inline legal-class-name-p check-class-name))
  66 (defun legal-class-name-p (thing)
  67   (symbolp thing))
  68
  69 (defun check-class-name (thing &optional (allow-nil t))
  70   ;; Apparently, FIND-CLASS and (SETF FIND-CLASS) accept any symbol,
  71   ;; but DEFCLASS only accepts non-NIL symbols.
  72   (if (or (not (legal-class-name-p thing))
  73           (and (null thing) (not allow-nil)))
  74       (error 'illegal-class-name-error :name thing)
  75       thing))
  76
  77 (define-condition class-not-found-error (sb-kernel::cell-error)
  78   ((sb-kernel::name :type (satisfies legal-class-name-p)))
  79   (:report (lambda (condition stream)
  80              (format stream "~@<There is no class named ~
  81                              ~/sb-impl:print-symbol-with-prefix/.~@:>"
  82                      (sb-kernel::cell-error-name condition)))))
  83
  84 (eval-when (:compile-toplevel :load-toplevel :execute)
  85   (defvar *create-classes-from-internal-structure-definitions-p* t))
  86 (declaim (always-bound *create-classes-from-internal-structure-definitions-p*))
  87
  88 (declaim (ftype function ensure-non-standard-class))
  89 (defun find-class-from-cell (symbol cell &optional (errorp t))
  90   (or (when cell
  91         (or (classoid-cell-pcl-class cell)
  92             (when *create-classes-from-internal-structure-definitions-p*
  93               (let ((classoid (classoid-cell-classoid cell)))
  94                 (when (and classoid
  95                            (or (condition-classoid-p classoid)
  96                                (defstruct-classoid-p classoid)))
  97                   (ensure-non-standard-class symbol classoid))))))
  98       (when errorp
  99         (check-class-name symbol)
 100         (error 'class-not-found-error :name symbol))))
 101
 102 (defun find-class (symbol &optional (errorp t) environment)
 103   (declare (ignore environment) (explicit-check))
 104   (find-class-from-cell symbol
 105                         (find-classoid-cell symbol)
 106                         errorp))
 107
 108 \f
 109 (define-compiler-macro find-class (&whole form
 110                                    symbol &optional (errorp t) environment)
 111   (declare (ignore environment))
 112   (if (and (constantp symbol)
 113            (legal-class-name-p (setf symbol (constant-form-value symbol)))
 114            (constantp errorp)
 115            (member **boot-state** '(braid complete)))
 116       (let ((errorp (not (null (constant-form-value errorp))))
 117             (cell (make-symbol "CLASSOID-CELL")))
 118         `(let ((,cell ,(find-classoid-cell symbol :create t)))
 119            (or (classoid-cell-pcl-class ,cell)
 120                ,(if errorp
 121                     `(find-class-from-cell ',symbol ,cell)
 122                     `(when (classoid-cell-classoid ,cell)
 123                        (find-class-from-cell ',symbol ,cell nil))))))
 124       form))
 125
 126 (declaim (ftype function update-ctors))
 127 (defun (setf find-class) (new-value name &optional errorp environment)
 128   (declare (ignore errorp environment))
 129   (check-class-name name)
 130   (with-single-package-locked-error
 131       (:symbol name "Using ~A as the class-name argument in ~
 132                      (SETF FIND-CLASS)"))
 133   (with-world-lock ()
 134     (let ((cell (find-classoid-cell name :create new-value)))
 135       (cond (new-value
 136              (setf (classoid-cell-pcl-class cell) new-value)
 137              (when (eq **boot-state** 'complete)
 138                (let ((classoid (class-classoid new-value)))
 139                  (setf (find-classoid name) classoid))))
 140             (cell
 141              (%clear-classoid name cell)))
 142       (when (or (eq **boot-state** 'complete)
 143                 (eq **boot-state** 'braid))
 144         (update-ctors 'setf-find-class :class new-value :name name))
 145       new-value)))
 146
 147 (flet ((call-gf (gf-nameize object slot-name env &optional newval)
 148          (aver (constantp slot-name env))
 149          `(funcall #',(funcall gf-nameize (constant-form-value slot-name env))
 150                    ,@newval ,object)))
 151   (defmacro accessor-slot-boundp (object slot-name &environment env)
 152     (call-gf 'slot-boundp-name object slot-name env))
 153
 154   (defmacro accessor-slot-value (object slot-name &environment env)
 155     `(truly-the (values t &optional)
 156                 ,(call-gf 'slot-reader-name object slot-name env)))
 157
 158   (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
 159     ;; Expand NEW-VALUE before deciding not to bind a temp var for OBJECT,
 160     ;; which should be eval'd first. We skip the binding if either new-value
 161     ;; is constant or a plain variable. This is still subtly wrong if NEW-VALUE
 162     ;; is a special, because we'll read it more than once.
 163     (setq new-value (%macroexpand new-value env))
 164     (let ((bind-object (unless (or (constantp new-value env) (atom new-value))
 165                          (let* ((object-var (gensym))
 166                                 (bind `((,object-var ,object))))
 167                            (setf object object-var)
 168                            bind)))
 169           ;; What's going on by not assuming that #'(SETF x) returns NEW-VALUE?
 170           ;; It seems wrong to return anything other than what the SETF fun
 171           ;; yielded. By analogy, when the SETF macro changes (SETF (F x) v)
 172           ;; into (funcall #'(setf F) ...), it does not insert any code to
 173           ;; enforce V as the overall value. So we do we do that here???
 174           (form `(let ((.new-value. ,new-value))
 175                    ,(call-gf 'slot-writer-name object slot-name env '(.new-value.))
 176                    .new-value.)))
 177       (if bind-object
 178           `(let ,bind-object ,form)
 179           form))))
 180
 181 (defmacro function-funcall (form &rest args)
 182   `(funcall (the function ,form) ,@args))
 183
 184 (defmacro function-apply (form &rest args)
 185   `(apply (the function ,form) ,@args))
 186 \f
 187 (defun get-setf-fun-name (name)
 188   `(setf ,name))