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