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 ;;; comment from CMU CL PCL:
  41 ;;;   These are age-old functions which CommonLisp cleaned-up away. They
  42 ;;;   probably exist in other packages in all CommonLisp
  43 ;;;   implementations, but I will leave it to the compiler to optimize
  44 ;;;   into calls to them.
  45 ;;;
  46 ;;; FIXME: MEMQ, ASSQ, and DELQ are already defined in SBCL, and we
  47 ;;; should use those definitions. POSQ and NEQ aren't defined in SBCL,
  48 ;;; and are used too often in PCL to make it appealing to hand expand
  49 ;;; all uses and then delete the macros, so they should be boosted up
  50 ;;; to SB-INT to stand by MEMQ, ASSQ, and DELQ.
  51 (defmacro memq (item list) `(member ,item ,list :test #'eq))
  52 (defmacro assq (item list) `(assoc ,item ,list :test #'eq))
  53 (defmacro delq (item list) `(delete ,item ,list :test #'eq))
  54 (defmacro posq (item list) `(position ,item ,list :test #'eq))
  55 (defmacro neq (x y) `(not (eq ,x ,y)))
  56 ;;; FIXME: CONSTANTLY-FOO should be boosted up to SB-INT too.
  57 (macrolet ((def-constantly-fun (name constant-expr)
  58              `(setf (symbol-function ',name)
  59                     (constantly ,constant-expr))))
  60   (def-constantly-fun constantly-t t)
  61   (def-constantly-fun constantly-nil nil)
  62   (def-constantly-fun constantly-0 0))
  63
  64 ;;; comment from original CMU CL PCL: ONCE-ONLY does the same thing as
  65 ;;; it does in zetalisp. I should have just lifted it from there but I
  66 ;;; am honest. Not only that but this one is written in Common Lisp. I
  67 ;;; feel a lot like bootstrapping, or maybe more like rebuilding Rome.
  68 ;;;
  69 ;;; FIXME: We should only need one ONCE-ONLY in SBCL, and there's one
  70 ;;; in SB-INT already. Can we use only one of these in both places?
  71 (defmacro once-only (vars &body body)
  72   (let ((gensym-var (gensym))
  73         (run-time-vars (gensym))
  74         (run-time-vals (gensym))
  75         (expand-time-val-forms ()))
  76     (dolist (var vars)
  77       (push `(if (or (symbolp ,var)
  78                      (numberp ,var)
  79                      (and (listp ,var)
  80                           (member (car ,var) '(quote function))))
  81                  ,var
  82                  (let ((,gensym-var (gensym)))
  83                    (push ,gensym-var ,run-time-vars)
  84                    (push ,var ,run-time-vals)
  85                    ,gensym-var))
  86             expand-time-val-forms))
  87     `(let* (,run-time-vars
  88             ,run-time-vals
  89             (wrapped-body
  90               (let ,(mapcar #'list vars (reverse expand-time-val-forms))
  91                 ,@body)))
  92        `(let ,(mapcar #'list (reverse ,run-time-vars)
  93                              (reverse ,run-time-vals))
  94           ,wrapped-body))))
  95
  96 ;;; FIXME: This looks like SBCL's PARSE-BODY, and should be shared.
  97 (eval-when (:compile-toplevel :load-toplevel :execute)
  98 (defun extract-declarations (body &optional environment)
  99   ;;(declare (values documentation declarations body))
 100   (let (documentation
 101         declarations
 102         form)
 103     (when (and (stringp (car body))
 104                (cdr body))
 105       (setq documentation (pop body)))
 106     (block outer
 107       (loop
 108         (when (null body) (return-from outer nil))
 109         (setq form (car body))
 110         (when (block inner
 111                 (loop (cond ((not (listp form))
 112                              (return-from outer nil))
 113                             ((eq (car form) 'declare)
 114                              (return-from inner 't))
 115                             (t
 116                              (multiple-value-bind (newform macrop)
 117                                   (macroexpand-1 form environment)
 118                                (if (or (not (eq newform form)) macrop)
 119                                    (setq form newform)
 120                                  (return-from outer nil)))))))
 121           (pop body)
 122           (dolist (declaration (cdr form))
 123             (push declaration declarations)))))
 124     (values documentation
 125             (and declarations `((declare ,.(nreverse declarations))))
 126             body)))
 127 ) ; EVAL-WHEN
 128
 129 (defun get-declaration (name declarations &optional default)
 130   (dolist (d declarations default)
 131     (dolist (form (cdr d))
 132       (when (and (consp form) (eq (car form) name))
 133         (return-from get-declaration (cdr form))))))
 134
 135 (defmacro collecting-once (&key initial-value)
 136    `(let* ((head ,initial-value)
 137            (tail ,(and initial-value `(last head))))
 138           (values #'(lambda (value)
 139                            (if (null head)
 140                                (setq head (setq tail (list value)))
 141                                (unless (memq value head)
 142                                  (setq tail
 143                                        (cdr (rplacd tail (list value)))))))
 144                   #'(lambda nil head))))
 145
 146 (defmacro doplist ((key val) plist &body body &environment env)
 147   (multiple-value-bind (doc decls bod)
 148       (extract-declarations body env)
 149     (declare (ignore doc))
 150     `(let ((.plist-tail. ,plist) ,key ,val)
 151        ,@decls
 152        (loop (when (null .plist-tail.) (return nil))
 153              (setq ,key (pop .plist-tail.))
 154              (when (null .plist-tail.)
 155                (error "malformed plist, odd number of elements"))
 156              (setq ,val (pop .plist-tail.))
 157              (progn ,@bod)))))
 158
 159 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
 160   `(let ((,var nil)
 161          (.dolist-carefully. ,list))
 162      (loop (when (null .dolist-carefully.) (return nil))
 163            (if (consp .dolist-carefully.)
 164                (progn
 165                  (setq ,var (pop .dolist-carefully.))
 166                  ,@body)
 167                (,improper-list-handler)))))
 168 \f
 169 ;;;; FIND-CLASS
 170 ;;;;
 171 ;;;; This is documented in the CLOS specification. FIXME: Except that
 172 ;;;; SBCL deviates from the spec by having CL:FIND-CLASS distinct from
 173 ;;;; PCL:FIND-CLASS, alas.
 174
 175 (defvar *find-class* (make-hash-table :test 'eq))
 176
 177 (defmacro find-class-cell-class (cell)
 178   `(car ,cell))
 179
 180 (defmacro find-class-cell-predicate (cell)
 181   `(cadr ,cell))
 182
 183 (defmacro find-class-cell-make-instance-function-keys (cell)
 184   `(cddr ,cell))
 185
 186 (defmacro make-find-class-cell (class-name)
 187   (declare (ignore class-name))
 188   '(list* nil #'constantly-nil nil))
 189
 190 (defun find-class-cell (symbol &optional dont-create-p)
 191   (or (gethash symbol *find-class*)
 192       (unless dont-create-p
 193         (unless (legal-class-name-p symbol)
 194           (error "~S is not a legal class name." symbol))
 195         (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
 196
 197 (defvar *create-classes-from-internal-structure-definitions-p* t)
 198
 199 (defun find-class-from-cell (symbol cell &optional (errorp t))
 200   (or (find-class-cell-class cell)
 201       (and *create-classes-from-internal-structure-definitions-p*
 202            (structure-type-p symbol)
 203            (find-structure-class symbol))
 204       (cond ((null errorp) nil)
 205             ((legal-class-name-p symbol)
 206              (error "There is no class named ~S." symbol))
 207             (t
 208              (error "~S is not a legal class name." symbol)))))
 209
 210 (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
 211   (unless (find-class-cell-class cell)
 212     (find-class-from-cell symbol cell errorp))
 213   (find-class-cell-predicate cell))
 214
 215 (defun legal-class-name-p (x)
 216   (and (symbolp x)
 217        (not (keywordp x))))
 218
 219 (defun find-class (symbol &optional (errorp t) environment)
 220   (declare (ignore environment))
 221   (find-class-from-cell symbol
 222                         (find-class-cell symbol errorp)
 223                         errorp))
 224
 225 (defun find-class-predicate (symbol &optional (errorp t) environment)
 226   (declare (ignore environment))
 227   (find-class-predicate-from-cell symbol
 228                                   (find-class-cell symbol errorp)
 229                                   errorp))
 230 \f
 231 ;;; This DEFVAR was originally in defs.lisp, now moved here.
 232 ;;;
 233 ;;; Possible values are NIL, EARLY, BRAID, or COMPLETE.
 234 ;;;
 235 ;;; KLUDGE: This should probably become
 236 ;;;   (DECLAIM (TYPE (MEMBER NIL :EARLY :BRAID :COMPLETE) *BOOT-STATE*))
 237 (defvar *boot-state* nil)
 238
 239 ;;; Note that in SBCL as in CMU CL,
 240 ;;;   COMMON-LISP:FIND-CLASS /= SB-PCL:FIND-CLASS.
 241 ;;; (Yes, this is a KLUDGE!)
 242 (define-compiler-macro find-class (&whole form
 243                                    symbol &optional (errorp t) environment)
 244   (declare (ignore environment))
 245   (if (and (constantp symbol)
 246            (legal-class-name-p (eval symbol))
 247            (constantp errorp)
 248            (member *boot-state* '(braid complete)))
 249       (let ((symbol (eval symbol))
 250             (errorp (not (null (eval errorp))))
 251             (class-cell (make-symbol "CLASS-CELL")))
 252         `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
 253            (or (find-class-cell-class ,class-cell)
 254                ,(if errorp
 255                     `(find-class-from-cell ',symbol ,class-cell t)
 256                     `(and (sb-kernel:class-cell-class
 257                            ',(sb-kernel:find-class-cell symbol))
 258                           (find-class-from-cell ',symbol ,class-cell nil))))))
 259       form))
 260
 261 ;;; FIXME: These #-SETF forms are pretty ugly. Could they please go away?
 262 #-setf
 263 (defsetf find-class (symbol &optional (errorp t) environment) (new-value)
 264   (declare (ignore errorp environment))
 265   `(SETF\ SB-PCL\ FIND-CLASS ,new-value ,symbol))
 266
 267 (defun #-setf SETF\ SB-PCL\ FIND-CLASS #+setf (setf find-class) (new-value
 268                                                                symbol)
 269   (if (legal-class-name-p symbol)
 270       (let ((cell (find-class-cell symbol)))
 271         (setf (find-class-cell-class cell) new-value)
 272         (when (or (eq *boot-state* 'complete)
 273                   (eq *boot-state* 'braid))
 274           (when (and new-value (class-wrapper new-value))
 275             (setf (find-class-cell-predicate cell)
 276                   (symbol-function (class-predicate-name new-value))))
 277           (when (and new-value (not (forward-referenced-class-p new-value)))
 278
 279             (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))
 280               (update-initialize-info-internal
 281                (initialize-info new-value (car keys+aok) nil (cdr keys+aok))
 282                'make-instance-function))))
 283         new-value)
 284       (error "~S is not a legal class name." symbol)))
 285
 286 #-setf
 287 (defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value)
 288   (declare (ignore errorp environment))
 289   `(SETF\ SB-PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol))
 290
 291 (defun #-setf SETF\ SB-PCL\ FIND-CLASS-PREDICATE
 292        #+setf (setf find-class-predicate)
 293     (new-value symbol)
 294   (if (legal-class-name-p symbol)
 295       (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
 296       (error "~S is not a legal class name." symbol)))
 297
 298 (defun find-wrapper (symbol)
 299   (class-wrapper (find-class symbol)))
 300
 301 (defmacro gathering1 (gatherer &body body)
 302   `(gathering ((.gathering1. ,gatherer))
 303      (macrolet ((gather1 (x) `(gather ,x .gathering1.)))
 304        ,@body)))
 305
 306 (defmacro vectorizing (&key (size 0))
 307   `(let* ((limit ,size)
 308           (result (make-array limit))
 309           (index 0))
 310      (values #'(lambda (value)
 311                  (if (= index limit)
 312                      (error "vectorizing more elements than promised")
 313                      (progn
 314                        (setf (svref result index) value)
 315                        (incf index)
 316                        value)))
 317              #'(lambda () result))))
 318
 319 ;;; These are augmented definitions of list-elements and list-tails from
 320 ;;; iterate.lisp. These versions provide the extra :by keyword which can
 321 ;;; be used to specify the step function through the list.
 322 (defmacro *list-elements (list &key (by #'cdr))
 323   `(let ((tail ,list))
 324      #'(lambda (finish)
 325          (if (endp tail)
 326              (funcall finish)
 327              (prog1 (car tail)
 328                     (setq tail (funcall ,by tail)))))))
 329
 330 (defmacro *list-tails (list &key (by #'cdr))
 331    `(let ((tail ,list))
 332       #'(lambda (finish)
 333           (prog1 (if (endp tail)
 334                      (funcall finish)
 335                      tail)
 336                  (setq tail (funcall ,by tail))))))
 337
 338 (defmacro function-funcall (form &rest args)
 339   `(funcall (the function ,form) ,@args))
 340
 341 (defmacro function-apply (form &rest args)
 342   `(apply (the function ,form) ,@args))
 343 \f
 344 ;;;; various nastiness to work around nonstandardness of SETF when PCL
 345 ;;;; was written
 346
 347 ;;; Convert a function name to its standard SETF function name. We
 348 ;;; have to do this hack because not all Common Lisps have yet
 349 ;;; converted to having SETF function specs.
 350 ;;;
 351 ;;; KLUDGE: We probably don't have to do this any more. But in Debian
 352 ;;; cmucl 2.4.8 the :SETF feature isn't set (?). Perhaps it's because of
 353 ;;; the comment ca. 10 lines down about how the built-in setf mechanism
 354 ;;; takes a hash table lookup each time? It would be nice to go one
 355 ;;; way or another on this, perhaps some benchmarking would be in order..
 356 ;;; (Oh, more info: In debian src/pcl/notes.text, which looks like stale
 357 ;;; documentation from 1992, it says TO DO: When CMU CL improves its
 358 ;;; SETF handling, remove the comment in macros.lisp beginning the line
 359 ;;; #+CMU (PUSHNEW :SETF *FEATURES*). So since CMU CL's (and now SBCL's)
 360 ;;; SETF handling seems OK to me these days, there's a fairly decent chance
 361 ;;; this would work.) -- WHN 19991203
 362 ;;;
 363 ;;; In a port that does have SETF function specs you can use those just by
 364 ;;; making the obvious simple changes to these functions. The rest of PCL
 365 ;;; believes that there are function names like (SETF <foo>), this is the
 366 ;;; only place that knows about this hack.
 367 (eval-when (:compile-toplevel :load-toplevel :execute)
 368 ; In 15e (and also 16c), using the built-in SETF mechanism costs
 369 ; a hash table lookup every time a SETF function is called.
 370 ; Uncomment the next line to use the built in SETF mechanism.
 371 ;#+cmu (pushnew :setf *features*)
 372 ) ; EVAL-WHEN
 373
 374 (eval-when (:compile-toplevel :load-toplevel :execute)
 375
 376 #-setf
 377 (defvar *setf-function-names* (make-hash-table :size 200 :test 'eq))
 378
 379 (defun get-setf-function-name (name)
 380   #+setf `(setf ,name)
 381   #-setf
 382   (or (gethash name *setf-function-names*)
 383       (setf (gethash name *setf-function-names*)
 384             (let ((pkg (symbol-package name)))
 385               (if pkg
 386                   (intern (format nil
 387                                   "SETF ~A ~A"
 388                                   (package-name pkg)
 389                                   (symbol-name name))
 390                           *pcl-package*)
 391                   (make-symbol (format nil "SETF ~A" (symbol-name name))))))))
 392
 393 ;;; Call this to define a setf macro for a function with the same behavior as
 394 ;;; specified by the SETF function cleanup proposal. Specifically, this will
 395 ;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
 396 ;;;
 397 ;;; do-standard-defsetf           A macro interface for use at top level
 398 ;;;                                   in files. Unfortunately, users may
 399 ;;;                                   have to use this for a while.
 400 ;;;
 401 ;;; do-standard-defsetfs-for-defclass    A special version called by defclass.
 402 ;;;
 403 ;;; do-standard-defsetf-1               A functional interface called by the
 404 ;;;                                   above, defmethod and defgeneric.
 405 ;;;                                   Since this is all a crock anyways,
 406 ;;;                                   users are free to call this as well.
 407 ;;;
 408 ;;; FIXME: Once we fix up SETF, a lot of stuff around here should evaporate.
 409 (defmacro do-standard-defsetf (&rest function-names)
 410   `(eval-when (:compile-toplevel :load-toplevel :execute)
 411      (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))
 412
 413 (defun do-standard-defsetfs-for-defclass (accessors)
 414   (dolist (name accessors) (do-standard-defsetf-1 name)))
 415
 416 (defun do-standard-defsetf-1 (function-name)
 417   #+setf
 418   (declare (ignore function-name))
 419   #+setf nil
 420   #-setf
 421   (unless (and (setfboundp function-name)
 422                (get function-name 'standard-setf))
 423     (setf (get function-name 'standard-setf) t)
 424     (let* ((setf-function-name (get-setf-function-name function-name)))
 425       (eval `(defsetf ,function-name (&rest accessor-args) (new-value)
 426                (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) accessor-args))
 427                       (vars (mapcar #'car bindings)))
 428                   `(let ,bindings
 429                       (,',setf-function-name ,new-value ,@vars))))))))
 430
 431 (defun setfboundp (symbol)
 432   (fboundp `(setf ,symbol)))
 433
 434 ) ; EVAL-WHEN
 435
 436 ;;; PCL, like user code, must endure the fact that we don't have a
 437 ;;; properly working SETF. Many things work because they get mentioned
 438 ;;; by a DEFCLASS or DEFMETHOD before they are used, but others have
 439 ;;; to be done by hand.
 440 ;;;
 441 ;;; FIXME: We don't have to do this stuff any more, do we?
 442 (do-standard-defsetf
 443   class-wrapper                          ;***
 444   generic-function-name
 445   method-function-plist
 446   method-function-get
 447   plist-value
 448   object-plist
 449   gdefinition
 450   slot-value-using-class)
 451
 452 (defsetf slot-value set-slot-value)