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