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