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