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 (/show "starting pcl/macros.lisp")
  30
  31 (declaim (declaration
  32           ;; These three nonstandard declarations seem to be used
  33           ;; privately within PCL itself to pass information around,
  34           ;; so we can't just delete them.
  35           %class
  36           %method-name
  37           %method-lambda-list
  38           ;; This declaration may also be used within PCL to pass
  39           ;; information around, I'm not sure. -- WHN 2000-12-30
  40           %variable-rebinding))
  41
  42 (/show "done with DECLAIM DECLARATION")
  43
  44 ;;; FIXME: This looks like SBCL's PARSE-BODY, and should be shared.
  45 (eval-when (:compile-toplevel :load-toplevel :execute)
  46
  47 (defun extract-declarations (body &optional environment)
  48   ;;(declare (values documentation declarations body))
  49   (let (documentation
  50         declarations
  51         form)
  52     (when (and (stringp (car body))
  53                (cdr body))
  54       (setq documentation (pop body)))
  55     (block outer
  56       (loop
  57         (when (null body) (return-from outer nil))
  58         (setq form (car body))
  59         (when (block inner
  60                 (loop (cond ((not (listp form))
  61                              (return-from outer nil))
  62                             ((eq (car form) 'declare)
  63                              (return-from inner t))
  64                             (t
  65                              (multiple-value-bind (newform macrop)
  66                                   (macroexpand-1 form environment)
  67                                (if (or (not (eq newform form)) macrop)
  68                                    (setq form newform)
  69                                  (return-from outer nil)))))))
  70           (pop body)
  71           (dolist (declaration (cdr form))
  72             (push declaration declarations)))))
  73     (values documentation
  74             (and declarations `((declare ,.(nreverse declarations))))
  75             body)))
  76 ) ; EVAL-WHEN
  77
  78 (/show "done with EVAL-WHEN (..) DEFUN EXTRACT-DECLARATIONS")
  79
  80 (defun get-declaration (name declarations &optional default)
  81   (dolist (d declarations default)
  82     (dolist (form (cdr d))
  83       (when (and (consp form) (eq (car form) name))
  84         (return-from get-declaration (cdr form))))))
  85
  86 (/show "pcl/macros.lisp 85")
  87
  88 (defmacro doplist ((key val) plist &body body &environment env)
  89   (multiple-value-bind (doc decls bod)
  90       (extract-declarations body env)
  91     (declare (ignore doc))
  92     `(let ((.plist-tail. ,plist) ,key ,val)
  93        ,@decls
  94        (loop (when (null .plist-tail.) (return nil))
  95              (setq ,key (pop .plist-tail.))
  96              (when (null .plist-tail.)
  97                (error "malformed plist, odd number of elements"))
  98              (setq ,val (pop .plist-tail.))
  99              (progn ,@bod)))))
 100
 101 (/show "pcl/macros.lisp 101")
 102
 103 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
 104   `(let ((,var nil)
 105          (.dolist-carefully. ,list))
 106      (loop (when (null .dolist-carefully.) (return nil))
 107            (if (consp .dolist-carefully.)
 108                (progn
 109                  (setq ,var (pop .dolist-carefully.))
 110                  ,@body)
 111                (,improper-list-handler)))))
 112 \f
 113 ;;;; FIND-CLASS
 114 ;;;;
 115 ;;;; This is documented in the CLOS specification. FIXME: Except that
 116 ;;;; SBCL deviates from the spec by having CL:FIND-CLASS distinct from
 117 ;;;; PCL:FIND-CLASS, alas.
 118
 119 (/show "pcl/macros.lisp 119")
 120
 121 (defvar *find-class* (make-hash-table :test 'eq))
 122
 123 (defmacro find-class-cell-class (cell)
 124   `(car ,cell))
 125
 126 (defmacro find-class-cell-predicate (cell)
 127   `(cadr ,cell))
 128
 129 (defmacro find-class-cell-make-instance-function-keys (cell)
 130   `(cddr ,cell))
 131
 132 (defmacro make-find-class-cell (class-name)
 133   (declare (ignore class-name))
 134   '(list* nil #'constantly-nil nil))
 135
 136 (defun find-class-cell (symbol &optional dont-create-p)
 137   (or (gethash symbol *find-class*)
 138       (unless dont-create-p
 139         (unless (legal-class-name-p symbol)
 140           (error "~S is not a legal class name." symbol))
 141         (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
 142
 143 (/show "pcl/macros.lisp 157")
 144
 145 (defvar *create-classes-from-internal-structure-definitions-p* t)
 146
 147 (defun find-class-from-cell (symbol cell &optional (errorp t))
 148   (or (find-class-cell-class cell)
 149       (and *create-classes-from-internal-structure-definitions-p*
 150            (structure-type-p symbol)
 151            (find-structure-class symbol))
 152       (cond ((null errorp) nil)
 153             ((legal-class-name-p symbol)
 154              (error "There is no class named ~S." symbol))
 155             (t
 156              (error "~S is not a legal class name." symbol)))))
 157
 158 (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
 159   (unless (find-class-cell-class cell)
 160     (find-class-from-cell symbol cell errorp))
 161   (find-class-cell-predicate cell))
 162
 163 (defun legal-class-name-p (x)
 164   (and (symbolp x)
 165        (not (keywordp x))))
 166
 167 (defun find-class (symbol &optional (errorp t) environment)
 168   (declare (ignore environment))
 169   (find-class-from-cell symbol
 170                         (find-class-cell symbol errorp)
 171                         errorp))
 172
 173 (defun find-class-predicate (symbol &optional (errorp t) environment)
 174   (declare (ignore environment))
 175   (find-class-predicate-from-cell symbol
 176                                   (find-class-cell symbol errorp)
 177                                   errorp))
 178 \f
 179 ;;; This DEFVAR was originally in defs.lisp, now moved here.
 180 ;;;
 181 ;;; Possible values are NIL, EARLY, BRAID, or COMPLETE.
 182 ;;;
 183 ;;; KLUDGE: This should probably become
 184 ;;;   (DECLAIM (TYPE (MEMBER NIL :EARLY :BRAID :COMPLETE) *BOOT-STATE*))
 185 (defvar *boot-state* nil)
 186
 187 (/show "pcl/macros.lisp 187")
 188
 189 ;;; Note that in SBCL as in CMU CL,
 190 ;;;   COMMON-LISP:FIND-CLASS /= SB-PCL:FIND-CLASS.
 191 ;;; (Yes, this is a KLUDGE!)
 192 (define-compiler-macro find-class (&whole form
 193                                    symbol &optional (errorp t) environment)
 194   (declare (ignore environment))
 195   (if (and (constantp symbol)
 196            (legal-class-name-p (eval symbol))
 197            (constantp errorp)
 198            (member *boot-state* '(braid complete)))
 199       (let ((symbol (eval symbol))
 200             (errorp (not (null (eval errorp))))
 201             (class-cell (make-symbol "CLASS-CELL")))
 202         `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
 203            (or (find-class-cell-class ,class-cell)
 204                ,(if errorp
 205                     `(find-class-from-cell ',symbol ,class-cell t)
 206                     `(and (sb-kernel:class-cell-class
 207                            ',(sb-kernel:find-class-cell symbol))
 208                           (find-class-from-cell ',symbol ,class-cell nil))))))
 209       form))
 210
 211 (defun (setf find-class) (new-value symbol)
 212   (if (legal-class-name-p symbol)
 213       (let ((cell (find-class-cell symbol)))
 214         (setf (find-class-cell-class cell) new-value)
 215         (when (or (eq *boot-state* 'complete)
 216                   (eq *boot-state* 'braid))
 217           (when (and new-value (class-wrapper new-value))
 218             (setf (find-class-cell-predicate cell)
 219                   (fdefinition (class-predicate-name new-value))))
 220           (when (and new-value (not (forward-referenced-class-p new-value)))
 221
 222             (dolist (keys+aok (find-class-cell-make-instance-function-keys
 223                                cell))
 224               (update-initialize-info-internal
 225                (initialize-info new-value (car keys+aok) nil (cdr keys+aok))
 226                'make-instance-function))))
 227         new-value)
 228       (error "~S is not a legal class name." symbol)))
 229
 230 (/show "pcl/macros.lisp 230")
 231
 232 (defun (setf find-class-predicate)
 233        (new-value symbol)
 234   (if (legal-class-name-p symbol)
 235     (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
 236     (error "~S is not a legal class name." symbol)))
 237
 238 (defun find-wrapper (symbol)
 239   (class-wrapper (find-class symbol)))
 240
 241 (/show "pcl/macros.lisp 241")
 242
 243 (defmacro function-funcall (form &rest args)
 244   `(funcall (the function ,form) ,@args))
 245
 246 (defmacro function-apply (form &rest args)
 247   `(apply (the function ,form) ,@args))
 248
 249 (/show "pcl/macros.lisp 249")
 250 \f
 251 (defun get-setf-fun-name (name)
 252   `(setf ,name))
 253
 254 (defsetf slot-value set-slot-value)
 255
 256 (/show "finished with pcl/macros.lisp")