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