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