src/compiler/macros.lisp

   1 ;;;; miscellaneous types and macros used in writing the compiler
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!C")
  13
  14 (declaim (special *wild-type* *universal-type* *compiler-error-context*))
  15
  16 ;;; An INLINEP value describes how a function is called. The values
  17 ;;; have these meanings:
  18 ;;;     NIL     No declaration seen: do whatever you feel like, but don't
  19 ;;;             dump an inline expansion.
  20 ;;; :NOTINLINE  NOTINLINE declaration seen: always do full function call.
  21 ;;;    :INLINE  INLINE declaration seen: save expansion, expanding to it
  22 ;;;             if policy favors.
  23 ;;; :MAYBE-INLINE
  24 ;;;             Retain expansion, but only use it opportunistically.
  25 (deftype inlinep () '(member :inline :maybe-inline :notinline nil))
  26 \f
  27 ;;;; the POLICY macro
  28
  29 ;;; a helper function for the POLICY macro: Return a list of
  30 ;;; POLICY-QUALITY-SLOT objects corresponding to the qualities which
  31 ;;; appear in EXPR.
  32 (eval-when (:compile-toplevel :load-toplevel :execute)
  33   (defun policy-quality-slots-used-by (expr)
  34     (let ((result nil))
  35       (labels ((recurse (x)
  36                  (if (listp x)
  37                      (map nil #'recurse x)
  38                      (let ((pqs (named-policy-quality-slot x)))
  39                        (when pqs
  40                          (pushnew pqs result))))))
  41         (recurse expr)
  42         result))))
  43
  44 ;;; syntactic sugar for querying optimization policy qualities
  45 ;;;
  46 ;;; Evaluate EXPR in terms of the current optimization policy for
  47 ;;; NODE, or if NODE is NIL, in terms of the current policy as defined
  48 ;;; by *DEFAULT-POLICY* and *CURRENT-POLICY*. (Using NODE=NIL is only
  49 ;;; well-defined during IR1 conversion.)
  50 ;;;
  51 ;;; EXPR is a form which accesses the policy values by referring to
  52 ;;; them by name, e.g. SPEED.
  53 (defmacro policy (node expr)
  54   (let* ((n-policy (gensym))
  55          (binds (mapcar
  56                  (lambda (pqs)
  57                    `(,(policy-quality-slot-quality pqs)
  58                      (,(policy-quality-slot-accessor pqs) ,n-policy)))
  59                  (policy-quality-slots-used-by expr))))
  60     (/show "in POLICY" expr binds)
  61     `(let* ((,n-policy (lexenv-policy
  62                         ,(if node
  63                              `(node-lexenv ,node)
  64                              '*lexenv*)))
  65             ,@binds)
  66        ,expr)))
  67 \f
  68 ;;;; source-hacking defining forms
  69
  70 ;;; to be passed to PARSE-DEFMACRO when we want compiler errors
  71 ;;; instead of real errors
  72 #!-sb-fluid (declaim (inline convert-condition-into-compiler-error))
  73 (defun convert-condition-into-compiler-error (datum &rest stuff)
  74   (if (stringp datum)
  75       (apply #'compiler-error datum stuff)
  76       (compiler-error "~A"
  77                       (if (symbolp datum)
  78                           (apply #'make-condition datum stuff)
  79                           datum))))
  80
  81 ;;; Parse a DEFMACRO-style lambda-list, setting things up so that a
  82 ;;; compiler error happens if the syntax is invalid.
  83 ;;;
  84 ;;; Define a function that converts a special form or other magical
  85 ;;; thing into IR1. LAMBDA-LIST is a defmacro style lambda list.
  86 ;;; START-VAR and CONT-VAR are bound to the start and result
  87 ;;; continuations for the resulting IR1. KIND is the function kind to
  88 ;;; associate with NAME.
  89 (defmacro def-ir1-translator (name (lambda-list start-var cont-var
  90                                                 &key (kind :special-form))
  91                                    &body body)
  92   (let ((fn-name (symbolicate "IR1-CONVERT-" name))
  93         (n-form (gensym))
  94         (n-env (gensym)))
  95     (multiple-value-bind (body decls doc)
  96         (parse-defmacro lambda-list n-form body name "special form"
  97                         :environment n-env
  98                         :error-fun 'convert-condition-into-compiler-error)
  99       `(progn
 100          (declaim (ftype (function (continuation continuation t) (values))
 101                          ,fn-name))
 102          (defun ,fn-name (,start-var ,cont-var ,n-form)
 103            (let ((,n-env *lexenv*))
 104              ,@decls
 105              ,body
 106              (values)))
 107          ,@(when doc
 108              `((setf (fdocumentation ',name 'function) ,doc)))
 109          ;; FIXME: Evidently "there can only be one!" -- we overwrite any
 110          ;; other :IR1-CONVERT value. This deserves a warning, I think.
 111          (setf (info :function :ir1-convert ',name) #',fn-name)
 112          (setf (info :function :kind ',name) ,kind)
 113          ;; It's nice to do this for error checking in the target
 114          ;; SBCL, but it's not nice to do this when we're running in
 115          ;; the cross-compilation host Lisp, which owns the
 116          ;; SYMBOL-FUNCTION of its COMMON-LISP symbols.
 117          #-sb-xc-host
 118          ,@(when (eq kind :special-form)
 119              `((setf (symbol-function ',name)
 120                      (lambda (&rest rest)
 121                        (declare (ignore rest))
 122                        (error "can't FUNCALL the SYMBOL-FUNCTION of ~
 123                                special forms")))))))))
 124
 125 ;;; (This is similar to DEF-IR1-TRANSLATOR, except that we pass if the
 126 ;;; syntax is invalid.)
 127 ;;;
 128 ;;; Define a macro-like source-to-source transformation for the
 129 ;;; function NAME. A source transform may "pass" by returning a
 130 ;;; non-nil second value. If the transform passes, then the form is
 131 ;;; converted as a normal function call. If the supplied arguments are
 132 ;;; not compatible with the specified LAMBDA-LIST, then the transform
 133 ;;; automatically passes.
 134 ;;;
 135 ;;; Source transforms may only be defined for functions. Source
 136 ;;; transformation is not attempted if the function is declared
 137 ;;; NOTINLINE. Source transforms should not examine their arguments.
 138 ;;; If it matters how the function is used, then DEFTRANSFORM should
 139 ;;; be used to define an IR1 transformation.
 140 ;;;
 141 ;;; If the desirability of the transformation depends on the current
 142 ;;; OPTIMIZE parameters, then the POLICY macro should be used to
 143 ;;; determine when to pass.
 144 (defmacro def-source-transform (name lambda-list &body body)
 145   (let ((fn-name
 146          (if (listp name)
 147              (collect ((pieces))
 148                (dolist (piece name)
 149                  (pieces "-")
 150                  (pieces piece))
 151                (apply #'symbolicate "SOURCE-TRANSFORM" (pieces)))
 152              (symbolicate "SOURCE-TRANSFORM-" name)))
 153         (n-form (gensym))
 154         (n-env (gensym)))
 155     (multiple-value-bind (body decls)
 156         (parse-defmacro lambda-list n-form body name "form"
 157                         :environment n-env
 158                         :error-fun `(lambda (&rest stuff)
 159                                       (declare (ignore stuff))
 160                                       (return-from ,fn-name
 161                                         (values nil t))))
 162       `(progn
 163          (defun ,fn-name (,n-form)
 164            (let ((,n-env *lexenv*))
 165              ,@decls
 166              ,body))
 167          (setf (info :function :source-transform ',name) #',fn-name)))))
 168
 169 ;;; Define a function that converts a use of (%PRIMITIVE NAME ..)
 170 ;;; into Lisp code. LAMBDA-LIST is a DEFMACRO-style lambda list.
 171 (defmacro def-primitive-translator (name lambda-list &body body)
 172   (let ((fn-name (symbolicate "PRIMITIVE-TRANSLATE-" name))
 173         (n-form (gensym))
 174         (n-env (gensym)))
 175     (multiple-value-bind (body decls)
 176         (parse-defmacro lambda-list n-form body name "%primitive"
 177                         :environment n-env
 178                         :error-fun 'convert-condition-into-compiler-error)
 179       `(progn
 180          (defun ,fn-name (,n-form)
 181            (let ((,n-env *lexenv*))
 182              ,@decls
 183              ,body))
 184          (setf (gethash ',name *primitive-translators*) ',fn-name)))))
 185 \f
 186 ;;;; boolean attribute utilities
 187 ;;;;
 188 ;;;; We need to maintain various sets of boolean attributes for known
 189 ;;;; functions and VOPs. To save space and allow for quick set
 190 ;;;; operations, we represent the attributes as bits in a fixnum.
 191
 192 (deftype attributes () 'fixnum)
 193
 194 (eval-when (:compile-toplevel :load-toplevel :execute)
 195
 196 ;;; Given a list of attribute names and an alist that translates them
 197 ;;; to masks, return the OR of the masks.
 198 (defun compute-attribute-mask (names alist)
 199   (collect ((res 0 logior))
 200     (dolist (name names)
 201       (let ((mask (cdr (assoc name alist))))
 202         (unless mask
 203           (error "unknown attribute name: ~S" name))
 204         (res mask)))
 205     (res)))
 206
 207 ) ; EVAL-WHEN
 208
 209 ;;; Parse the specification and generate some accessor macros.
 210 ;;;
 211 ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
 212 ;;;   (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
 213 ;;;   #+SB-XC-HOST
 214 ;;;   (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
 215 ;;; arrangement, in order to get it to work in cross-compilation. This
 216 ;;; duplication should be removed, perhaps by rewriting the macro in a
 217 ;;; more cross-compiler-friendly way, or perhaps just by using some
 218 ;;; (MACROLET ((FROB ..)) .. FROB .. FROB) form, but I don't want to
 219 ;;; do it now, because the system isn't running yet, so it'd be too
 220 ;;; hard to check that my changes were correct -- WHN 19990806
 221 (def!macro def-boolean-attribute (name &rest attribute-names)
 222   #!+sb-doc
 223   "Def-Boolean-Attribute Name Attribute-Name*
 224   Define a new class of boolean attributes, with the attributes having the
 225   specified Attribute-Names. Name is the name of the class, which is used to
 226   generate some macros to manipulate sets of the attributes:
 227
 228     NAME-attributep attributes attribute-name*
 229       Return true if one of the named attributes is present, false otherwise.
 230       When set with SETF, updates the place Attributes setting or clearing the
 231       specified attributes.
 232
 233     NAME-attributes attribute-name*
 234       Return a set of the named attributes."
 235
 236   (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
 237         (test-name (symbolicate name "-ATTRIBUTEP")))
 238     (collect ((alist))
 239       (do ((mask 1 (ash mask 1))
 240            (names attribute-names (cdr names)))
 241           ((null names))
 242         (alist (cons (car names) mask)))
 243
 244       `(progn
 245
 246          (eval-when (:compile-toplevel :load-toplevel :execute)
 247            (defparameter ,translations-name ',(alist)))
 248
 249          (defmacro ,test-name (attributes &rest attribute-names)
 250            "Automagically generated boolean attribute test function. See
 251             Def-Boolean-Attribute."
 252            `(logtest ,(compute-attribute-mask attribute-names
 253                                               ,translations-name)
 254                      (the attributes ,attributes)))
 255
 256          (define-setf-expander ,test-name (place &rest attributes
 257                                                  &environment env)
 258            "Automagically generated boolean attribute setter. See
 259             Def-Boolean-Attribute."
 260            #-sb-xc-host (declare (type sb!c::lexenv env))
 261            ;; FIXME: It would be better if &ENVIRONMENT arguments
 262            ;; were automatically declared to have type LEXENV by the
 263            ;; hairy-argument-handling code.
 264            (multiple-value-bind (temps values stores set get)
 265                (get-setf-expansion place env)
 266              (when (cdr stores)
 267                (error "multiple store variables for ~S" place))
 268              (let ((newval (gensym))
 269                    (n-place (gensym))
 270                    (mask (compute-attribute-mask attributes
 271                                                  ,translations-name)))
 272                (values `(,@temps ,n-place)
 273                        `(,@values ,get)
 274                        `(,newval)
 275                        `(let ((,(first stores)
 276                                (if ,newval
 277                                    (logior ,n-place ,mask)
 278                                    (logand ,n-place ,(lognot mask)))))
 279                           ,set
 280                           ,newval)
 281                        `(,',test-name ,n-place ,@attributes)))))
 282
 283          (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
 284            "Automagically generated boolean attribute creation function. See
 285             Def-Boolean-Attribute."
 286            (compute-attribute-mask attribute-names ,translations-name))))))
 287 ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
 288
 289 ;;; And now for some gratuitous pseudo-abstraction...
 290 (defmacro attributes-union (&rest attributes)
 291   #!+sb-doc
 292   "Returns the union of all the sets of boolean attributes which are its
 293   arguments."
 294   `(the attributes
 295         (logior ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes))))
 296 (defmacro attributes-intersection (&rest attributes)
 297   #!+sb-doc
 298   "Returns the intersection of all the sets of boolean attributes which are its
 299   arguments."
 300   `(the attributes
 301         (logand ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes))))
 302 (declaim (ftype (function (attributes attributes) boolean) attributes=))
 303 #!-sb-fluid (declaim (inline attributes=))
 304 (defun attributes= (attr1 attr2)
 305   #!+sb-doc
 306   "Returns true if the attributes present in Attr1 are identical to those in
 307   Attr2."
 308   (eql attr1 attr2))
 309 \f
 310 ;;;; lambda-list parsing utilities
 311 ;;;;
 312 ;;;; IR1 transforms, optimizers and type inferencers need to be able
 313 ;;;; to parse the IR1 representation of a function call using a
 314 ;;;; standard function lambda-list.
 315
 316 (eval-when (:compile-toplevel :load-toplevel :execute)
 317
 318 ;;; Given a DEFTRANSFORM-style lambda-list, generate code that parses
 319 ;;; the arguments of a combination with respect to that lambda-list.
 320 ;;; BODY is the the list of forms which are to be evaluated within the
 321 ;;; bindings. ARGS is the variable that holds list of argument
 322 ;;; continuations. ERROR-FORM is a form which is evaluated when the
 323 ;;; syntax of the supplied arguments is incorrect or a non-constant
 324 ;;; argument keyword is supplied. Defaults and other gunk are ignored.
 325 ;;; The second value is a list of all the arguments bound. We make the
 326 ;;; variables IGNORABLE so that we don't have to manually declare them
 327 ;;; Ignore if their only purpose is to make the syntax work.
 328 (declaim (ftype (function (list list symbol t) list) parse-deftransform))
 329 (defun parse-deftransform (lambda-list body args error-form)
 330   (multiple-value-bind (req opt restp rest keyp keys allowp)
 331       (parse-lambda-list lambda-list)
 332     (let* ((min-args (length req))
 333            (max-args (+ min-args (length opt)))
 334            (n-keys (gensym)))
 335       (collect ((binds)
 336                 (vars)
 337                 (pos 0 +)
 338                 (keywords))
 339         (dolist (arg req)
 340           (vars arg)
 341           (binds `(,arg (nth ,(pos) ,args)))
 342           (pos 1))
 343
 344         (dolist (arg opt)
 345           (let ((var (if (atom arg) arg (first  arg))))
 346             (vars var)
 347             (binds `(,var (nth ,(pos) ,args)))
 348             (pos 1)))
 349
 350         (when restp
 351           (vars rest)
 352           (binds `(,rest (nthcdr ,(pos) ,args))))
 353
 354         (dolist (spec keys)
 355           (if (or (atom spec) (atom (first spec)))
 356               (let* ((var (if (atom spec) spec (first spec)))
 357                      (key (intern (symbol-name var) "KEYWORD")))
 358                 (vars var)
 359                 (binds `(,var (find-keyword-continuation ,n-keys ,key)))
 360                 (keywords key))
 361               (let* ((head (first spec))
 362                      (var (second head))
 363                      (key (first head)))
 364                 (vars var)
 365                 (binds `(,var (find-keyword-continuation ,n-keys ,key)))
 366                 (keywords key))))
 367
 368         (let ((n-length (gensym))
 369               (limited-legal (not (or restp keyp))))
 370           (values
 371            `(let ((,n-length (length ,args))
 372                   ,@(when keyp `((,n-keys (nthcdr ,(pos) ,args)))))
 373               (unless (and
 374                        ;; FIXME: should be PROPER-LIST-OF-LENGTH-P
 375                        ,(if limited-legal
 376                             `(<= ,min-args ,n-length ,max-args)
 377                             `(<= ,min-args ,n-length))
 378                        ,@(when keyp
 379                            (if allowp
 380                                `((check-keywords-constant ,n-keys))
 381                                `((check-transform-keys ,n-keys ',(keywords))))))
 382                 ,error-form)
 383               (let ,(binds)
 384                 (declare (ignorable ,@(vars)))
 385                 ,@body))
 386            (vars)))))))
 387
 388 ) ; EVAL-WHEN
 389 \f
 390 ;;;; DEFTRANSFORM
 391
 392 ;;; Parse the lambda-list and generate code to test the policy and
 393 ;;; automatically create the result lambda.
 394 (defmacro deftransform (name (lambda-list &optional (arg-types '*)
 395                                           (result-type '*)
 396                                           &key result policy node defun-only
 397                                           eval-name important (when :native))
 398                              &body body-decls-doc)
 399   #!+sb-doc
 400   "Deftransform Name (Lambda-List [Arg-Types] [Result-Type] {Key Value}*)
 401                Declaration* [Doc-String] Form*
 402   Define an IR1 transformation for NAME. An IR1 transformation computes a
 403   lambda that replaces the function variable reference for the call. A
 404   transform may pass (decide not to transform the call) by calling the
 405   GIVE-UP-IR1-TRANSFORM function. LAMBDA-LIST both determines how the
 406   current call is parsed and specifies the LAMBDA-LIST for the resulting
 407   lambda.
 408
 409   We parse the call and bind each of the lambda-list variables to the
 410   continuation which represents the value of the argument. When parsing
 411   the call, we ignore the defaults, and always bind the variables for
 412   unsupplied arguments to NIL. If a required argument is missing, an
 413   unknown keyword is supplied, or an argument keyword is not a constant,
 414   then the transform automatically passes. The DECLARATIONS apply to the
 415   bindings made by DEFTRANSFORM at transformation time, rather than to
 416   the variables of the resulting lambda. Bound-but-not-referenced
 417   warnings are suppressed for the lambda-list variables. The DOC-STRING
 418   is used when printing efficiency notes about the defined transform.
 419
 420   Normally, the body evaluates to a form which becomes the body of an
 421   automatically constructed lambda. We make LAMBDA-LIST the lambda-list
 422   for the lambda, and automatically insert declarations of the argument
 423   and result types. If the second value of the body is non-null, then it
 424   is a list of declarations which are to be inserted at the head of the
 425   lambda. Automatic lambda generation may be inhibited by explicitly
 426   returning a lambda from the body.
 427
 428   The ARG-TYPES and RESULT-TYPE are used to create a function type
 429   which the call must satisfy before transformation is attempted. The
 430   function type specifier is constructed by wrapping (FUNCTION ...)
 431   around these values, so the lack of a restriction may be specified by
 432   omitting the argument or supplying *. The argument syntax specified in
 433   the ARG-TYPES need not be the same as that in the LAMBDA-LIST, but the
 434   transform will never happen if the syntaxes can't be satisfied
 435   simultaneously. If there is an existing transform for the same
 436   function that has the same type, then it is replaced with the new
 437   definition.
 438
 439   These are the legal keyword options:
 440     :Result - A variable which is bound to the result continuation.
 441     :Node   - A variable which is bound to the combination node for the call.
 442     :Policy - A form which is supplied to the POLICY macro to determine whether
 443               this transformation is appropriate. If the result is false, then
 444               the transform automatically passes.
 445     :Eval-Name
 446             - The name and argument/result types are actually forms to be
 447               evaluated. Useful for getting closures that transform similar
 448               functions.
 449     :Defun-Only
 450             - Don't actually instantiate a transform, instead just DEFUN
 451               Name with the specified transform definition function. This may
 452               be later instantiated with %DEFTRANSFORM.
 453     :Important
 454             - If supplied and non-NIL, note this transform as ``important,''
 455               which means efficiency notes will be generated when this
 456               transform fails even if brevity=speed (but not if brevity>speed)
 457     :When {:Native | :Byte | :Both}
 458             - Indicates whether this transform applies to native code,
 459               byte-code or both (default :native.)"
 460
 461   (when (and eval-name defun-only)
 462     (error "can't specify both DEFUN-ONLY and EVAL-NAME"))
 463   (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
 464     (let ((n-args (gensym))
 465           (n-node (or node (gensym)))
 466           (n-decls (gensym))
 467           (n-lambda (gensym))
 468           (decls-body `(,@decls ,@body)))
 469       (multiple-value-bind (parsed-form vars)
 470           (parse-deftransform lambda-list
 471                               (if policy
 472                                   `((unless (policy ,n-node ,policy)
 473                                       (give-up-ir1-transform))
 474                                     ,@decls-body)
 475                                   body)
 476                               n-args
 477                               '(give-up-ir1-transform))
 478         (let ((stuff
 479                `((,n-node)
 480                  (let* ((,n-args (basic-combination-args ,n-node))
 481                         ,@(when result
 482                             `((,result (node-cont ,n-node)))))
 483                    (multiple-value-bind (,n-lambda ,n-decls)
 484                        ,parsed-form
 485                      (if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda))
 486                          ,n-lambda
 487                        `(lambda ,',lambda-list
 488                           (declare (ignorable ,@',vars))
 489                           ,@,n-decls
 490                           ,,n-lambda)))))))
 491           (if defun-only
 492               `(defun ,name ,@(when doc `(,doc)) ,@stuff)
 493               `(%deftransform
 494                 ,(if eval-name name `',name)
 495                 ,(if eval-name
 496                      ``(function ,,arg-types ,,result-type)
 497                      `'(function ,arg-types ,result-type))
 498                 #'(lambda ,@stuff)
 499                 ,doc
 500                 ,(if important t nil)
 501                 ,when)))))))
 502 \f
 503 ;;;; DEFKNOWN and DEFOPTIMIZER
 504
 505 ;;; This macro should be the way that all implementation independent
 506 ;;; information about functions is made known to the compiler.
 507 ;;;
 508 ;;; FIXME: The comment above suggests that perhaps some of my added
 509 ;;; FTYPE declarations are in poor taste. Should I change my
 510 ;;; declarations, or change the comment, or what?
 511 ;;;
 512 ;;; FIXME: DEFKNOWN is needed only at build-the-system time. Figure
 513 ;;; out some way to keep it from appearing in the target system.
 514 (defmacro defknown (name arg-types result-type &optional (attributes '(any))
 515                          &rest keys)
 516   #!+sb-doc
 517   "Defknown Name Arg-Types Result-Type [Attributes] {Key Value}*
 518   Declare the function Name to be a known function. We construct a type
 519   specifier for the function by wrapping (FUNCTION ...) around the Arg-Types
 520   and Result-Type. Attributes is an unevaluated list of boolean
 521   attributes of the function. These attributes are meaningful here:
 522       call
 523          May call functions that are passed as arguments. In order
 524          to determine what other effects are present, we must find
 525          the effects of all arguments that may be functions.
 526
 527       unsafe
 528          May incorporate arguments in the result or somehow pass
 529          them upward.
 530
 531       unwind
 532          May fail to return during correct execution. Errors
 533          are O.K.
 534
 535       any
 536          The (default) worst case. Includes all the other bad
 537          things, plus any other possible bad thing.
 538
 539       foldable
 540          May be constant-folded. The function has no side effects,
 541          but may be affected by side effects on the arguments. E.g.
 542          SVREF, MAPC.
 543
 544       flushable
 545          May be eliminated if value is unused. The function has
 546          no side effects except possibly CONS. If a function is
 547          defined to signal errors, then it is not flushable even
 548          if it is movable or foldable.
 549
 550       movable
 551          May be moved with impunity. Has no side effects except
 552          possibly CONS,and is affected only by its arguments.
 553
 554       predicate
 555           A true predicate likely to be open-coded. This is a
 556           hint to IR1 conversion that it should ensure calls always
 557           appear as an IF test. Not usually specified to Defknown,
 558           since this is implementation dependent, and is usually
 559           automatically set by the Define-VOP :Conditional option.
 560
 561   Name may also be a list of names, in which case the same information
 562   is given to all the names. The keywords specify the initial values
 563   for various optimizers that the function might have."
 564   (when (and (intersection attributes '(any call unwind))
 565              (intersection attributes '(movable)))
 566     (error "function cannot have both good and bad attributes: ~S" attributes))
 567
 568   `(%defknown ',(if (and (consp name)
 569                          (not (eq (car name) 'setf)))
 570                     name
 571                     (list name))
 572               '(function ,arg-types ,result-type)
 573               (ir1-attributes ,@(if (member 'any attributes)
 574                                     (union '(call unsafe unwind) attributes)
 575                                     attributes))
 576               ,@keys))
 577
 578 ;;; Create a function which parses combination args according to
 579 ;;; LAMBDA-LIST, optionally storing it in a FUNCTION-INFO slot.
 580 (defmacro defoptimizer (what (lambda-list &optional (n-node (gensym))
 581                                           &rest vars)
 582                              &body body)
 583   #!+sb-doc
 584   "Defoptimizer (Function Kind) (Lambda-List [Node-Var] Var*)
 585                 Declaration* Form*
 586   Define some Kind of optimizer for the named Function. Function must be a
 587   known function. Lambda-List is used to parse the arguments to the
 588   combination as in Deftransform. If the argument syntax is invalid or there
 589   are non-constant keys, then we simply return NIL.
 590
 591   The function is DEFUN'ed as Function-Kind-OPTIMIZER. Possible kinds are
 592   DERIVE-TYPE, OPTIMIZER, LTN-ANNOTATE and IR2-CONVERT. If a symbol is
 593   specified instead of a (Function Kind) list, then we just do a DEFUN with the
 594   symbol as its name, and don't do anything with the definition. This is
 595   useful for creating optimizers to be passed by name to DEFKNOWN.
 596
 597   If supplied, Node-Var is bound to the combination node being optimized. If
 598   additional Vars are supplied, then they are used as the rest of the optimizer
 599   function's lambda-list. LTN-ANNOTATE methods are passed an additional POLICY
 600   argument, and IR2-CONVERT methods are passed an additional IR2-BLOCK
 601   argument."
 602
 603   (let ((name (if (symbolp what) what
 604                   (symbolicate (first what) "-" (second what) "-OPTIMIZER"))))
 605
 606     (let ((n-args (gensym)))
 607       `(progn
 608         (defun ,name (,n-node ,@vars)
 609           (let ((,n-args (basic-combination-args ,n-node)))
 610             ,(parse-deftransform lambda-list body n-args
 611                                  `(return-from ,name nil))))
 612         ,@(when (consp what)
 613             `((setf (,(symbolicate "FUNCTION-INFO-" (second what))
 614                      (function-info-or-lose ',(first what)))
 615                     #',name)))))))
 616 \f
 617 ;;;; IR groveling macros
 618
 619 (defmacro do-blocks ((block-var component &optional ends result) &body body)
 620   #!+sb-doc
 621   "Do-Blocks (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}*
 622   Iterate over the blocks in a component, binding Block-Var to each block in
 623   turn. The value of Ends determines whether to iterate over dummy head and
 624   tail blocks:
 625     NIL   -- Skip Head and Tail (the default)
 626     :Head -- Do head but skip tail
 627     :Tail -- Do tail but skip head
 628     :Both -- Do both head and tail
 629
 630   If supplied, Result-Form is the value to return."
 631   (unless (member ends '(nil :head :tail :both))
 632     (error "losing ENDS value: ~S" ends))
 633   (let ((n-component (gensym))
 634         (n-tail (gensym)))
 635     `(let* ((,n-component ,component)
 636             (,n-tail ,(if (member ends '(:both :tail))
 637                           nil
 638                           `(component-tail ,n-component))))
 639        (do ((,block-var ,(if (member ends '(:both :head))
 640                              `(component-head ,n-component)
 641                              `(block-next (component-head ,n-component)))
 642                         (block-next ,block-var)))
 643            ((eq ,block-var ,n-tail) ,result)
 644          ,@body))))
 645 (defmacro do-blocks-backwards ((block-var component &optional ends result) &body body)
 646   #!+sb-doc
 647   "Do-Blocks-Backwards (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}*
 648   Like Do-Blocks, only iterate over the blocks in reverse order."
 649   (unless (member ends '(nil :head :tail :both))
 650     (error "losing ENDS value: ~S" ends))
 651   (let ((n-component (gensym))
 652         (n-head (gensym)))
 653     `(let* ((,n-component ,component)
 654             (,n-head ,(if (member ends '(:both :head))
 655                           nil
 656                           `(component-head ,n-component))))
 657        (do ((,block-var ,(if (member ends '(:both :tail))
 658                              `(component-tail ,n-component)
 659                              `(block-prev (component-tail ,n-component)))
 660                         (block-prev ,block-var)))
 661            ((eq ,block-var ,n-head) ,result)
 662          ,@body))))
 663
 664 ;;; Could change it not to replicate the code someday perhaps...
 665 (defmacro do-uses ((node-var continuation &optional result) &body body)
 666   #!+sb-doc
 667   "Do-Uses (Node-Var Continuation [Result]) {Declaration}* {Form}*
 668   Iterate over the uses of Continuation, binding Node to each one
 669   successively."
 670   (once-only ((n-cont continuation))
 671     `(ecase (continuation-kind ,n-cont)
 672        (:unused)
 673        (:inside-block
 674         (block nil
 675           (let ((,node-var (continuation-use ,n-cont)))
 676             ,@body
 677             ,result)))
 678        ((:block-start :deleted-block-start)
 679         (dolist (,node-var (block-start-uses (continuation-block ,n-cont))
 680                            ,result)
 681           ,@body)))))
 682
 683 ;;; In the forward case, we terminate on Last-Cont so that we don't
 684 ;;; have to worry about our termination condition being changed when
 685 ;;; new code is added during the iteration. In the backward case, we
 686 ;;; do NODE-PREV before evaluating the body so that we can keep going
 687 ;;; when the current node is deleted.
 688 ;;;
 689 ;;; When RESTART-P is supplied to DO-NODES, we start iterating over
 690 ;;; again at the beginning of the block when we run into a
 691 ;;; continuation whose block differs from the one we are trying to
 692 ;;; iterate over, either beacuse the block was split, or because a
 693 ;;; node was deleted out from under us (hence its block is NIL.) If
 694 ;;; the block start is deleted, we just punt. With RESTART-P, we are
 695 ;;; also more careful about termination, re-indirecting the BLOCK-LAST
 696 ;;; each time.
 697 (defmacro do-nodes ((node-var cont-var block &key restart-p) &body body)
 698   #!+sb-doc
 699   "Do-Nodes (Node-Var Cont-Var Block {Key Value}*) {Declaration}* {Form}*
 700   Iterate over the nodes in Block, binding Node-Var to the each node and
 701   Cont-Var to the node's Cont. The only keyword option is Restart-P, which
 702   causes iteration to be restarted when a node is deleted out from under us (if
 703   not supplied, this is an error.)"
 704   (let ((n-block (gensym))
 705         (n-last-cont (gensym)))
 706     `(let* ((,n-block ,block)
 707             ,@(unless restart-p
 708                 `((,n-last-cont (node-cont (block-last ,n-block))))))
 709        (do* ((,node-var (continuation-next (block-start ,n-block))
 710                         ,(if restart-p
 711                              `(cond
 712                                ((eq (continuation-block ,cont-var) ,n-block)
 713                                 (assert (continuation-next ,cont-var))
 714                                 (continuation-next ,cont-var))
 715                                (t
 716                                 (let ((start (block-start ,n-block)))
 717                                   (unless (eq (continuation-kind start)
 718                                               :block-start)
 719                                     (return nil))
 720                                   (continuation-next start))))
 721                              `(continuation-next ,cont-var)))
 722              (,cont-var (node-cont ,node-var) (node-cont ,node-var)))
 723             (())
 724          ,@body
 725          (when ,(if restart-p
 726                     `(eq ,node-var (block-last ,n-block))
 727                     `(eq ,cont-var ,n-last-cont))
 728            (return nil))))))
 729 (defmacro do-nodes-backwards ((node-var cont-var block) &body body)
 730   #!+sb-doc
 731   "Do-Nodes-Backwards (Node-Var Cont-Var Block) {Declaration}* {Form}*
 732   Like Do-Nodes, only iterates in reverse order."
 733   (let ((n-block (gensym))
 734         (n-start (gensym))
 735         (n-last (gensym))
 736         (n-next (gensym)))
 737     `(let* ((,n-block ,block)
 738             (,n-start (block-start ,n-block))
 739             (,n-last (block-last ,n-block)))
 740        (do* ((,cont-var (node-cont ,n-last) ,n-next)
 741              (,node-var ,n-last (continuation-use ,cont-var))
 742              (,n-next (node-prev ,node-var) (node-prev ,node-var)))
 743             (())
 744          ,@body
 745          (when (eq ,n-next ,n-start)
 746            (return nil))))))
 747
 748 ;;; The lexical environment is presumably already null...
 749 (defmacro with-ir1-environment (node &rest forms)
 750   #!+sb-doc
 751   "With-IR1-Environment Node Form*
 752   Bind the IR1 context variables so that IR1 conversion can be done after the
 753   main conversion pass has finished."
 754   (let ((n-node (gensym)))
 755     `(let* ((,n-node ,node)
 756             (*current-component* (block-component (node-block ,n-node)))
 757             (*lexenv* (node-lexenv ,n-node))
 758             (*current-path* (node-source-path ,n-node)))
 759        ,@forms)))
 760
 761 ;;; Bind the hashtables used for keeping track of global variables,
 762 ;;; functions, &c. Also establish condition handlers.
 763 (defmacro with-ir1-namespace (&body forms)
 764   `(let ((*free-variables* (make-hash-table :test 'eq))
 765          (*free-functions* (make-hash-table :test 'equal))
 766          (*constants* (make-hash-table :test 'equal))
 767          (*source-paths* (make-hash-table :test 'eq)))
 768      (handler-bind ((compiler-error #'compiler-error-handler)
 769                     (style-warning #'compiler-style-warning-handler)
 770                     (warning #'compiler-warning-handler))
 771        ,@forms)))
 772
 773 (defmacro lexenv-find (name slot &key test)
 774   #!+sb-doc
 775   "LEXENV-FIND Name Slot {Key Value}*
 776   Look up Name in the lexical environment namespace designated by Slot,
 777   returning the <value, T>, or <NIL, NIL> if no entry. The :TEST keyword
 778   may be used to determine the name equality predicate."
 779   (once-only ((n-res `(assoc ,name (,(symbolicate "LEXENV-" slot) *lexenv*)
 780                              :test ,(or test '#'eq))))
 781     `(if ,n-res
 782          (values (cdr ,n-res) t)
 783          (values nil nil))))
 784 \f
 785 ;;; These functions are called by the expansion of the DEFPRINTER
 786 ;;; macro to do the actual printing.
 787 (declaim (ftype (function (symbol t stream &optional t) (values))
 788                 defprinter-prin1 defprinter-princ))
 789 (defun defprinter-prin1 (name value stream &optional indent)
 790   (declare (ignore indent))
 791   (defprinter-prinx #'prin1 name value stream))
 792 (defun defprinter-princ (name value stream &optional indent)
 793   (declare (ignore indent))
 794   (defprinter-prinx #'princ name value stream))
 795 (defun defprinter-prinx (prinx name value stream)
 796   (declare (type function prinx))
 797   (write-char #\space stream)
 798   (when *print-pretty*
 799     (pprint-newline :linear stream))
 800   (format stream ":~A " name)
 801   (funcall prinx value stream)
 802   (values))
 803
 804 ;; Define some kind of reasonable PRINT-OBJECT method for a STRUCTURE-OBJECT.
 805 ;;
 806 ;; NAME is the name of the structure class, and CONC-NAME is the same as in
 807 ;; DEFSTRUCT.
 808 ;;
 809 ;; The SLOT-DESCS describe how each slot should be printed. Each SLOT-DESC can
 810 ;; be a slot name, indicating that the slot should simply be printed. A
 811 ;; SLOT-DESC may also be a list of a slot name and other stuff. The other stuff
 812 ;; is composed of keywords followed by expressions. The expressions are
 813 ;; evaluated with the variable which is the slot name bound to the value of the
 814 ;; slot. These keywords are defined:
 815 ;;
 816 ;; :PRIN1    Print the value of the expression instead of the slot value.
 817 ;; :PRINC    Like :PRIN1, only princ the value
 818 ;; :TEST     Only print something if the test is true.
 819 ;;
 820 ;; If no printing thing is specified then the slot value is printed as PRIN1.
 821 ;;
 822 ;; The structure being printed is bound to STRUCTURE and the stream is bound to
 823 ;; STREAM.
 824 (defmacro defprinter ((name &key (conc-name (concatenate 'simple-string
 825                                                          (symbol-name name)
 826                                                          "-")))
 827                       &rest slot-descs)
 828   (flet ((sref (slot-name)
 829            `(,(symbolicate conc-name slot-name) structure)))
 830     (collect ((prints))
 831       (dolist (slot-desc slot-descs)
 832         (if (atom slot-desc)
 833           (prints `(defprinter-prin1 ',slot-desc ,(sref slot-desc) stream))
 834           (let ((sname (first slot-desc))
 835                 (test t))
 836             (collect ((stuff))
 837               (do ((option (rest slot-desc) (cddr option)))
 838                   ((null option)
 839                    (prints
 840                     `(let ((,sname ,(sref sname)))
 841                        (when ,test
 842                          ,@(or (stuff)
 843                                `((defprinter-prin1 ',sname ,sname
 844                                    stream)))))))
 845                 (case (first option)
 846                   (:prin1
 847                    (stuff `(defprinter-prin1 ',sname ,(second option)
 848                              stream)))
 849                   (:princ
 850                    (stuff `(defprinter-princ ',sname ,(second option)
 851                              stream)))
 852                   (:test (setq test (second option)))
 853                   (t
 854                    (error "bad DEFPRINTER option: ~S" (first option)))))))))
 855
 856       `(def!method print-object ((structure ,name) stream)
 857          (print-unreadable-object (structure stream :type t)
 858            (pprint-logical-block (stream nil)
 859              ;;(pprint-indent :current 2 stream)
 860              ,@(prints)))))))
 861 \f
 862 ;;;; the Event statistics/trace utility
 863
 864 ;;; FIXME: This seems to be useful for troubleshooting and
 865 ;;; experimentation, not for ordinary use, so it should probably
 866 ;;; become conditional on SB-SHOW.
 867
 868 (eval-when (:compile-toplevel :load-toplevel :execute)
 869
 870 (defstruct event-info
 871   ;; The name of this event.
 872   (name (required-argument) :type symbol)
 873   ;; The string rescribing this event.
 874   (description (required-argument) :type string)
 875   ;; The name of the variable we stash this in.
 876   (var (required-argument) :type symbol)
 877   ;; The number of times this event has happened.
 878   (count 0 :type fixnum)
 879   ;; The level of significance of this event.
 880   (level (required-argument) :type unsigned-byte)
 881   ;; If true, a function that gets called with the node that the event
 882   ;; happened to.
 883   (action nil :type (or function null)))
 884
 885 ;;; A hashtable from event names to event-info structures.
 886 (defvar *event-info* (make-hash-table :test 'eq))
 887
 888 ;;; Return the event info for Name or die trying.
 889 (declaim (ftype (function (t) event-info) event-info-or-lose))
 890 (defun event-info-or-lose (name)
 891   (let ((res (gethash name *event-info*)))
 892     (unless res
 893       (error "~S is not the name of an event." name))
 894     res))
 895
 896 ) ; EVAL-WHEN
 897
 898 (declaim (ftype (function (symbol) fixnum) event-count))
 899 (defun event-count (name)
 900   #!+sb-doc
 901   "Return the number of times that Event has happened."
 902   (event-info-count (event-info-or-lose name)))
 903
 904 (declaim (ftype (function (symbol) (or function null)) event-action))
 905 (defun event-action (name)
 906   #!+sb-doc
 907   "Return the function that is called when Event happens. If this is null,
 908   there is no action. The function is passed the node to which the event
 909   happened, or NIL if there is no relevant node. This may be set with SETF."
 910   (event-info-action (event-info-or-lose name)))
 911 (declaim (ftype (function (symbol (or function null)) (or function null))
 912                 %set-event-action))
 913 (defun %set-event-action (name new-value)
 914   (setf (event-info-action (event-info-or-lose name))
 915         new-value))
 916 (defsetf event-action %set-event-action)
 917
 918 (declaim (ftype (function (symbol) unsigned-byte) event-level))
 919 (defun event-level (name)
 920   #!+sb-doc
 921   "Return the non-negative integer which represents the level of significance
 922   of the event Name. This is used to determine whether to print a message when
 923   the event happens. This may be set with SETF."
 924   (event-info-level (event-info-or-lose name)))
 925 (declaim (ftype (function (symbol unsigned-byte) unsigned-byte) %set-event-level))
 926 (defun %set-event-level (name new-value)
 927   (setf (event-info-level (event-info-or-lose name))
 928         new-value))
 929 (defsetf event-level %set-event-level)
 930
 931 ;;; Make an EVENT-INFO structure and stash it in a variable so we can
 932 ;;; get at it quickly.
 933 (defmacro defevent (name description &optional (level 0))
 934   #!+sb-doc
 935   "Defevent Name Description
 936   Define a new kind of event. Name is a symbol which names the event and
 937   Description is a string which describes the event. Level (default 0) is the
 938   level of significance associated with this event; it is used to determine
 939   whether to print a Note when the event happens."
 940   (let ((var-name (symbolicate "*" name "-EVENT-INFO*")))
 941     `(eval-when (:compile-toplevel :load-toplevel :execute)
 942        (defvar ,var-name
 943          (make-event-info :name ',name
 944                           :description ',description
 945                           :var ',var-name
 946                           :level ,level))
 947        (setf (gethash ',name *event-info*) ,var-name)
 948        ',name)))
 949
 950 (declaim (type unsigned-byte *event-note-threshold*))
 951 (defvar *event-note-threshold* 1
 952   #!+sb-doc
 953   "This variable is a non-negative integer specifying the lowest level of
 954   event that will print a note when it occurs.")
 955
 956 ;;; Increment the counter and do any action. Mumble about the event if
 957 ;;; policy indicates.
 958 (defmacro event (name &optional node)
 959   #!+sb-doc
 960   "Event Name Node
 961   Note that the event with the specified Name has happened. Node is evaluated
 962   to determine the node to which the event happened."
 963   `(%event ,(event-info-var (event-info-or-lose name)) ,node))
 964
 965 (declaim (ftype (function (&optional unsigned-byte stream) (values)) event-statistics))
 966 (defun event-statistics (&optional (min-count 1) (stream *standard-output*))
 967   #!+sb-doc
 968   "Print a listing of events and their counts, sorted by the count. Events
 969   that happened fewer than Min-Count times will not be printed. Stream is the
 970   stream to write to."
 971   (collect ((info))
 972     (maphash #'(lambda (k v)
 973                  (declare (ignore k))
 974                  (when (>= (event-info-count v) min-count)
 975                    (info v)))
 976              *event-info*)
 977     (dolist (event (sort (info) #'> :key #'event-info-count))
 978       (format stream "~6D: ~A~%" (event-info-count event)
 979               (event-info-description event)))
 980     (values))
 981   (values))
 982
 983 (declaim (ftype (function nil (values)) clear-event-statistics))
 984 (defun clear-event-statistics ()
 985   (maphash #'(lambda (k v)
 986                (declare (ignore k))
 987                (setf (event-info-count v) 0))
 988            *event-info*)
 989   (values))
 990 \f
 991 ;;;; functions on directly-linked lists (linked through specialized
 992 ;;;; NEXT operations)
 993
 994 #!-sb-fluid (declaim (inline find-in position-in map-in))
 995
 996 (defun find-in (next
 997                 element
 998                 list
 999                 &key
1000                 (key #'identity)
1001                 (test #'eql test-p)
1002                 (test-not nil not-p))
1003   #!+sb-doc
1004   "Find Element in a null-terminated List linked by the accessor function
1005   Next. Key, Test and Test-Not are the same as for generic sequence
1006   functions."
1007   (when (and test-p not-p)
1008     (error "It's silly to supply both :TEST and :TEST-NOT arguments."))
1009   (if not-p
1010       (do ((current list (funcall next current)))
1011           ((null current) nil)
1012         (unless (funcall test-not (funcall key current) element)
1013           (return current)))
1014       (do ((current list (funcall next current)))
1015           ((null current) nil)
1016         (when (funcall test (funcall key current) element)
1017           (return current)))))
1018
1019 (defun position-in (next
1020                     element
1021                     list
1022                     &key
1023                     (key #'identity)
1024                     (test #'eql test-p)
1025                     (test-not nil not-p))
1026   #!+sb-doc
1027   "Return the position of Element (or NIL if absent) in a null-terminated List
1028   linked by the accessor function Next. Key, Test and Test-Not are the same as
1029   for generic sequence functions."
1030   (when (and test-p not-p)
1031     (error "It's silly to supply both :TEST and :TEST-NOT arguments."))
1032   (if not-p
1033       (do ((current list (funcall next current))
1034            (i 0 (1+ i)))
1035           ((null current) nil)
1036         (unless (funcall test-not (funcall key current) element)
1037           (return i)))
1038       (do ((current list (funcall next current))
1039            (i 0 (1+ i)))
1040           ((null current) nil)
1041         (when (funcall test (funcall key current) element)
1042           (return i)))))
1043
1044 (defun map-in (next function list)
1045   #!+sb-doc
1046   "Map Function over the elements in a null-terminated List linked by the
1047   accessor function Next, returning a list of the results."
1048   (collect ((res))
1049     (do ((current list (funcall next current)))
1050         ((null current))
1051       (res (funcall function current)))
1052     (res)))
1053
1054 ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
1055 ;;;   (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
1056 ;;;   #+SB-XC-HOST
1057 ;;;   (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
1058 ;;; arrangement, in order to get it to work in cross-compilation. This
1059 ;;; duplication should be removed, perhaps by rewriting the macro in a more
1060 ;;; cross-compiler-friendly way, or perhaps just by using some (MACROLET ((FROB
1061 ;;; ..)) .. FROB .. FROB) form, or perhaps by completely eliminating this macro
1062 ;;; and its partner PUSH-IN, but I don't want to do it now, because the system
1063 ;;; isn't running yet, so it'd be too hard to check that my changes were
1064 ;;; correct -- WHN 19990806
1065 (def!macro deletef-in (next place item &environment env)
1066   (multiple-value-bind (temps vals stores store access)
1067       (get-setf-expansion place env)
1068     (when (cdr stores)
1069       (error "multiple store variables for ~S" place))
1070     (let ((n-item (gensym))
1071           (n-place (gensym))
1072           (n-current (gensym))
1073           (n-prev (gensym)))
1074       `(let* (,@(mapcar #'list temps vals)
1075               (,n-place ,access)
1076               (,n-item ,item))
1077          (if (eq ,n-place ,n-item)
1078              (let ((,(first stores) (,next ,n-place)))
1079                ,store)
1080              (do ((,n-prev ,n-place ,n-current)
1081                   (,n-current (,next ,n-place)
1082                               (,next ,n-current)))
1083                  ((eq ,n-current ,n-item)
1084                   (setf (,next ,n-prev)
1085                         (,next ,n-current)))))
1086          (values)))))
1087 ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
1088
1089 ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
1090 ;;;   (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
1091 ;;;   #+SB-XC-HOST
1092 ;;;   (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
1093 ;;; arrangement, in order to get it to work in cross-compilation. This
1094 ;;; duplication should be removed, perhaps by rewriting the macro in a more
1095 ;;; cross-compiler-friendly way, or perhaps just by using some (MACROLET ((FROB
1096 ;;; ..)) .. FROB .. FROB) form, or perhaps by completely eliminating this macro
1097 ;;; and its partner DELETEF-IN, but I don't want to do it now, because the
1098 ;;; system isn't running yet, so it'd be too hard to check that my changes were
1099 ;;; correct -- WHN 19990806
1100 (def!macro push-in (next item place &environment env)
1101   #!+sb-doc
1102   "Push Item onto a list linked by the accessor function Next that is stored in
1103   Place."
1104   (multiple-value-bind (temps vals stores store access)
1105       (get-setf-expansion place env)
1106     (when (cdr stores)
1107       (error "multiple store variables for ~S" place))
1108     `(let (,@(mapcar #'list temps vals)
1109            (,(first stores) ,item))
1110        (setf (,next ,(first stores)) ,access)
1111        ,store
1112        (values))))
1113 ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
1114
1115 (defmacro position-or-lose (&rest args)
1116   `(or (position ,@args)
1117        (error "Shouldn't happen?")))