src/pcl/iterate.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3
   4 ;;;; FIXME: It'd be nice to get rid of all 750 lines of code in this
   5 ;;;; file, plus miscellaneous cruft elsewhere (e.g. the definition of
   6 ;;;; the SB-ITERATE package). There are only 20 calls to this ITERATE
   7 ;;;; macro in the PCL code. (There's another ITERATE macro used in the
   8 ;;;; classic CMU CL code, but that's different.) Most if not all of
   9 ;;;; them would be easy to replace with ANSI LOOP or simpler standard
  10 ;;;; iteration constructs.
  11
  12 ;;;; This software is derived from software originally released by Xerox
  13 ;;;; Corporation. Copyright and release statements follow. Later modifications
  14 ;;;; to the software are in the public domain and are provided with
  15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  16 ;;;; information.
  17
  18 ;;;; copyright information from original PCL sources:
  19 ;;;;
  20 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  21 ;;;; All rights reserved.
  22 ;;;;
  23 ;;;; Use and copying of this software and preparation of derivative works based
  24 ;;;; upon this software are permitted. Any distribution of this software or
  25 ;;;; derivative works must comply with all applicable United States export
  26 ;;;; control laws.
  27 ;;;;
  28 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  29 ;;;; warranty about the software, its performance or its conformity to any
  30 ;;;; specification.
  31
  32 (in-package "SB-ITERATE")
  33 \f
  34 ;;; Are warnings to be issued for iterate/gather forms that aren't
  35 ;;; optimized?
  36 ;;;   NIL   => never
  37 ;;;   :USER => those resulting from user code
  38 ;;;   T     => always, even if it's the iteration macro that's suboptimal.
  39 (defvar *iterate-warnings* :any)
  40
  41 ;;; ITERATE macro
  42 (defmacro iterate (clauses &body body &environment env)
  43   (optimize-iterate-form clauses body env))
  44
  45 ;;; temporary variable names used by ITERATE expansions
  46 (defparameter *iterate-temp-vars-list*
  47   '(iterate-temp-1 iterate-temp-2 iterate-temp-3 iterate-temp-4
  48     iterate-temp-5 iterate-temp-6 iterate-temp-7 iterate-temp-8))
  49
  50 (defun
  51  optimize-iterate-form
  52  (clauses body iterate-env)
  53  (let*
  54   ((temp-vars *iterate-temp-vars-list*)
  55    (block-name (gensym))
  56    (finish-form `(return-from ,block-name))
  57    (bound-vars (mapcan #'(lambda (clause)
  58                                 (let ((names (first clause)))
  59                                      (if (listp names)
  60                                          (copy-list names)
  61                                          (list names))))
  62                       clauses))
  63    iterate-decls generator-decls update-forms bindings leftover-body)
  64   (do ((tail bound-vars (cdr tail)))
  65       ((null tail))
  66     ;; Check for duplicates
  67     (when (member (car tail)
  68                  (cdr tail))
  69         (warn "Variable appears more than once in ITERATE: ~S" (car tail))))
  70   (flet
  71    ((get-iterate-temp nil
  72
  73            ;; Make temporary var. Note that it is ok to re-use these symbols
  74            ;; in each iterate, because they are not used within BODY.
  75            (or (pop temp-vars)
  76                (gensym))))
  77    (dolist (clause clauses)
  78        (cond
  79         ((or (not (consp clause))
  80              (not (consp (cdr clause))))
  81          (warn "bad syntax in ITERATE: clause not of form (var iterator): ~S"
  82                clause))
  83         (t
  84          (unless (null (cddr clause))
  85                 (warn
  86        "probable parenthesis error in ITERATE clause--more than 2 elements: ~S"
  87                       clause))
  88          (multiple-value-bind
  89           (let-body binding-type let-bindings localdecls otherdecls extra-body)
  90           (expand-into-let (second clause)
  91                  'iterate iterate-env)
  92
  93           ;; We have expanded the generator clause and parsed it into
  94           ;; its LET pieces.
  95           (prog*
  96            ((vars (first clause))
  97             gen-args renamed-vars)
  98            (setq vars (if (listp vars)
  99                           (copy-list vars)
 100                           (list vars)))
 101                                                ; VARS is now a (fresh) list of
 102                                                ; all iteration vars bound in
 103                                                ; this clause
 104            (cond
 105             ((eq let-body :abort)
 106                                                ; Already issued a warning
 107                                                ; about malformedness
 108              )
 109             ((null (setq let-body (function-lambda-p let-body 1)))
 110                                                ; Not of the expected form
 111              (let ((generator (second clause)))
 112                   (cond ((and (consp generator)
 113                               (fboundp (car generator)))
 114                                                ; It looks ok--a macro or
 115                                                ; function here--so the guy who
 116                                                ; wrote it just didn't do it in
 117                                                ; an optimizable way
 118                          (maybe-warn :definition "could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))"
 119                                 generator))
 120                         (t                   ; Perhaps it's just a
 121                                                ; misspelling?  Probably user
 122                                                ; error
 123                            (maybe-warn :user
 124                                 "Iterate operator in clause ~S is not fboundp."
 125                                 generator)))
 126                   (setq let-body :abort)))
 127             (t
 128
 129              ;; We have something of the form #'(LAMBDA (finisharg) ...),
 130              ;; possibly with some LET bindings around it. LET-BODY =
 131              ;; ((finisharg) ...).
 132              (setq let-body (cdr let-body))
 133              (setq gen-args (pop let-body))
 134              (when let-bindings
 135
 136                  ;; The first transformation we want to perform is
 137                  ;; "LET-eversion": turn (let* ((generator (let (..bindings..)
 138                  ;; #'(lambda ...)))) ..body..) into (let* (..bindings..
 139                  ;; (generator #'(lambda ...))) ..body..). This
 140                  ;; transformation is valid if nothing in body refers to any
 141                  ;; of the bindings, something we can ensure by
 142                  ;; alpha-converting the inner let (substituting new names for
 143                  ;; each var). Of course, none of those vars can be special,
 144                  ;; but we already checked for that above.
 145                  (multiple-value-setq (let-bindings renamed-vars)
 146                         (rename-let-bindings let-bindings binding-type
 147                                iterate-env leftover-body #'get-iterate-temp))
 148                  (setq leftover-body nil)
 149                                                ; If there was any leftover
 150                                                ; from previous, it is now
 151                                                ; consumed.
 152                  )
 153
 154              ;; The second transformation is substituting the body of the
 155              ;; generator (LAMBDA (finish-arg) . gen-body) for its appearance
 156              ;; in the update form (funcall generator #'(lambda ()
 157              ;; finish-form)), then simplifying that form. The requirement
 158              ;; for this part is that the generator body not refer to any
 159              ;; variables that are bound between the generator binding and the
 160              ;; appearance in the loop body. The only variables bound in that
 161              ;; interval are generator temporaries, which have unique names so
 162              ;; are no problem, and the iteration variables remaining for
 163              ;; subsequent clauses. We'll discover the story as we walk the
 164              ;; body.
 165              (multiple-value-bind (finishdecl other rest)
 166                  (parse-declarations let-body gen-args)
 167               (declare (ignore finishdecl))
 168                                                ; Pull out declares, if any,
 169                                                ; separating out the one(s)
 170                                                ; referring to the finish arg,
 171                                                ; which we will throw away.
 172               (when other
 173                                                ; Combine remaining decls with
 174                                                ; decls extracted from the LET,
 175                                                ; if any.
 176                   (setq otherdecls (nconc otherdecls other)))
 177               (setq let-body (cond
 178                               (otherdecls
 179                                                ; There are interesting
 180                                                ; declarations, so have to keep
 181                                                ; it wrapped.
 182                                `(let nil (declare ,@otherdecls)
 183                                      ,@rest))
 184                               ((null (cdr rest))
 185                                                ; Only one form left
 186                                (first rest))
 187                               (t `(progn ,@rest)))))
 188              (unless (eq (setq let-body (iterate-transform-body let-body
 189                                                iterate-env renamed-vars
 190                                                (first gen-args)
 191                                                finish-form bound-vars clause))
 192                          :abort)
 193
 194                  ;; Skip the rest if transformation failed. Warning has
 195                  ;; already been issued.
 196
 197                  ;; Note possible further optimization: if LET-BODY expanded
 198                  ;; into (prog1 oldvalue prepare-for-next-iteration), as so
 199                  ;; many do, then we could in most cases split the PROG1 into
 200                  ;; two pieces: do the (setq var oldvalue) here, and do the
 201                  ;; prepare-for-next-iteration at the bottom of the loop.
 202                  ;; This does a slight optimization of the PROG1 and also
 203                  ;; rearranges the code in a way that a reasonably clever
 204                  ;; compiler might detect how to get rid of redundant
 205                  ;; variables altogether (such as happens with INTERVAL and
 206                  ;; LIST-TAILS); that would make the whole thing closer to
 207                  ;; what you might have coded by hand. However, to do this
 208                  ;; optimization, we need to ensure that (a) the
 209                  ;; prepare-for-next-iteration refers freely to no vars other
 210                  ;; than the internal vars we have extracted from the LET, and
 211                  ;; (b) that the code has no side effects. These are both
 212                  ;; true for all the iterators defined by this module, but how
 213                  ;; shall we represent side-effect info and/or tap into the
 214                  ;; compiler's knowledge of same?
 215                  (when localdecls
 216                                                ; There were declarations for
 217                                                ; the generator locals--have to
 218                                                ; keep them for later, and
 219                                                ; rename the vars mentioned
 220                      (setq
 221                       generator-decls
 222                       (nconc
 223                        generator-decls
 224                        (mapcar
 225                         #'(lambda
 226                            (decl)
 227                            (let ((head (car decl)))
 228                                 (cons head (if (eq head 'type)
 229                                                (cons (second decl)
 230                                                      (sublis renamed-vars
 231                                                             (cddr decl)))
 232                                                (sublis renamed-vars
 233                                                       (cdr decl))))))
 234                         localdecls)))))))
 235
 236            ;; Finished analyzing clause now. LET-BODY is the form which, when
 237            ;; evaluated, returns updated values for the iteration variable(s)
 238            ;; VARS.
 239            (when (eq let-body :abort)
 240
 241                ;; Some punt case: go with the formal semantics: bind a var to
 242                ;; the generator, then call it in the update section
 243                (let
 244                 ((gvar (get-iterate-temp))
 245                  (generator (second clause)))
 246                 (setq
 247                  let-bindings
 248                  (list (list gvar
 249                              (cond
 250                               ;; FIXME: This conditional was here with this
 251                               ;; comment in old CMU CL PCL. Does Python really
 252                               ;; think it's unreachable?
 253                               ;;#-cmu ; Python thinks this is unreachable.
 254                               (leftover-body
 255                                                ; Have to use this up
 256                                `(progn ,@(prog1 leftover-body (setq
 257                                                                   leftover-body
 258                                                                     nil))
 259                                        generator))
 260                               (t generator)))))
 261                 (setq let-body `(funcall ,gvar #'(lambda nil ,finish-form)))))
 262            (push (mv-setq (copy-list vars)
 263                         let-body)
 264                  update-forms)
 265            (dolist (v vars)
 266              (declare (ignore v))
 267              ;; Pop off the vars we have now bound from the list of vars to
 268              ;; watch out for -- we'll bind them right now.
 269              (pop bound-vars))
 270            (setq bindings
 271                  (nconc bindings let-bindings
 272                         (cond (extra-body
 273                                ;; There was some computation to do after the
 274                                ;; bindings--here's our chance.
 275                                (cons (list (first vars)
 276                                            `(progn ,@extra-body nil))
 277                                      (rest vars)))
 278                               (t vars))))))))))
 279   (do ((tail body (cdr tail)))
 280       ((not (and (consp tail)
 281                  (consp (car tail))
 282                  (eq (caar tail)
 283                      'declare)))
 284
 285        ;; TAIL now points at first non-declaration. If there were
 286        ;; declarations, pop them off so they appear in the right place
 287        (unless (eq tail body)
 288            (setq iterate-decls (ldiff body tail))
 289            (setq body tail))))
 290   `(block ,block-name
 291        (let* ,bindings ,@(and generator-decls
 292                               `((declare ,@generator-decls)))
 293              ,@iterate-decls
 294              ,@leftover-body
 295              (loop ,@(nreverse update-forms)
 296                    ,@body)))))
 297
 298 (defun expand-into-let (clause parent-name env)
 299
 300        ;; Return values: Body, LET[*], bindings, localdecls, otherdecls, extra
 301        ;; body, where BODY is a single form. If multiple forms in a LET, the
 302        ;; preceding forms are returned as extra body. Returns :ABORT if it
 303        ;; issued a punt warning.
 304        (prog ((expansion clause)
 305               expandedp binding-type let-bindings let-body)
 306              expand
 307              (multiple-value-setq (expansion expandedp)
 308                     (macroexpand-1 expansion env))
 309              (cond ((not (consp expansion))
 310                                                ; Shouldn't happen
 311                     )
 312                    ((symbolp (setq binding-type (first expansion)))
 313                     (case binding-type
 314                         ((let let*)
 315                            (setq let-bindings (second expansion))
 316                                                ; List of variable bindings
 317                            (setq let-body (cddr expansion))
 318                            (go handle-let))))
 319                    ((and (consp binding-type)
 320                          (eq (car binding-type)
 321                              'lambda)
 322                          (not (find-if #'(lambda (x)
 323                                                 (member x lambda-list-keywords)
 324                                                 )
 325                                      (setq let-bindings (second binding-type)))
 326                               )
 327                          (eql (length (second expansion))
 328                               (length let-bindings))
 329                          (null (cddr expansion)))
 330                                                ; A simple LAMBDA form can be
 331                                                ; treated as LET
 332                     (setq let-body (cddr binding-type))
 333                     (setq let-bindings (mapcar #'list let-bindings (second
 334                                                                     expansion))
 335                           )
 336                     (setq binding-type 'let)
 337                     (go handle-let)))
 338
 339              ;; Fall thru if not a LET
 340              (cond (expandedp             ; try expanding again
 341                           (go expand))
 342                    (t                     ; Boring--return form as the
 343                                                ; body
 344                       (return expansion)))
 345              handle-let
 346              (return (let ((locals (variables-from-let let-bindings))
 347                            extra-body specials)
 348                           (multiple-value-bind (localdecls otherdecls let-body)
 349                               (parse-declarations let-body locals)
 350                            (cond ((setq specials (extract-special-bindings
 351                                                   locals localdecls))
 352                                   (maybe-warn (cond ((find-if
 353                                                       #'var-globally-special-p
 354                                                       specials)
 355                                                      ;; This could be the
 356                                                      ;; fault of a user
 357                                                      ;; proclamation.
 358                                                      :user)
 359                                                     (t :definition))
 360
 361           "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)"
 362                                          parent-name clause specials)
 363                                   :abort)
 364                                  (t (values (cond ((not (consp let-body))
 365
 366                                                ; Null body of LET?  unlikely,
 367                                                ; but someone else will likely
 368                                                ; complain
 369                                                    nil)
 370                                                   ((null (cdr let-body))
 371
 372                                                ; A single expression, which we
 373                                                ; hope is (function
 374                                                ; (lambda...))
 375                                                    (first let-body))
 376                                                   (t
 377
 378                           ;; More than one expression. These are forms to
 379                           ;; evaluate after the bindings but before the
 380                           ;; generator form is returned. Save them to
 381                           ;; evaluate in the next convenient place. Note that
 382                           ;; this is ok, as there is no construct that can
 383                           ;; cause a LET to return prematurely (without
 384                           ;; returning also from some surrounding construct).
 385                                                      (setq extra-body
 386                                                            (butlast let-body))
 387                                                      (car (last let-body))))
 388                                            binding-type let-bindings localdecls
 389                                            otherdecls extra-body))))))))
 390
 391 (defun variables-from-let (bindings)
 392
 393        ;; Return a list of the variables bound in the first argument to LET[*].
 394        (mapcar #'(lambda (binding)
 395                         (if (consp binding)
 396                             (first binding)
 397                             binding))
 398               bindings))
 399
 400 (defun iterate-transform-body (let-body iterate-env renamed-vars finish-arg
 401                                      finish-form bound-vars clause)
 402
 403 ;;; This is the second major transformation for a single iterate clause.
 404 ;;; LET-BODY is the body of the iterator after we have extracted its local
 405 ;;; variables and declarations. We have two main tasks: (1) Substitute
 406 ;;; internal temporaries for occurrences of the LET variables; the alist
 407 ;;; RENAMED-VARS specifies this transformation. (2) Substitute evaluation of
 408 ;;; FINISH-FORM for any occurrence of (funcall FINISH-ARG). Along the way, we
 409 ;;; check for forms that would invalidate these transformations: occurrence of
 410 ;;; FINISH-ARG outside of a funcall, and free reference to any element of
 411 ;;; BOUND-VARS. CLAUSE & TYPE are the original ITERATE clause and its type
 412 ;;; (ITERATE or ITERATE*), for purpose of error messages. On success, we
 413 ;;; return the transformed body; on failure, :ABORT.
 414
 415        (walk-form
 416         let-body
 417         iterate-env
 418         (lambda (form context env)
 419           (declare (ignore context))
 420
 421           ;; We need to substitute RENAMED-VARS, as well as turn
 422           ;; (FUNCALL finish-arg) into the finish form.
 423           (cond ((symbolp form)
 424                  (let (renaming)
 425                    (cond ((and (eq form finish-arg)
 426                                (var-same-p form env iterate-env))
 427                           ;; an occurrence of the finish arg outside
 428                           ;; of FUNCALL context: I can't handle this!
 429                           (maybe-warn :definition "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it."
 430                                       (second clause))
 431                           (return-from iterate-transform-body
 432                             :abort))
 433                          ((and (setq renaming (assoc form renamed-vars))
 434                                (var-same-p form env iterate-env))
 435                           ;; Reference to one of the vars
 436                           ;; we're renaming
 437                           (cdr renaming))
 438                          ((and (member form bound-vars)
 439                                (var-same-p form env iterate-env))
 440                           ;; FORM is a var that is bound in this same
 441                           ;; ITERATE, or bound later in this ITERATE*.
 442                           ;; This is a conflict.
 443                           (maybe-warn :user "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable."
 444                                       (second clause)
 445                                       form)
 446                           (return-from iterate-transform-body
 447                             :abort))
 448                          (t form))))
 449                 ((and (consp form)
 450                       (eq (first form)
 451                           'funcall)
 452                       (eq (second form)
 453                           finish-arg)
 454                       (var-same-p (second form) env
 455                                   iterate-env))
 456                  ;; (FUNCALL finish-arg) => finish-form
 457                  (unless (null (cddr form))
 458                    (maybe-warn :definition
 459                                "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored."
 460                                (second clause)
 461                                (cddr form)))
 462                  finish-form)
 463                 (t form)))))
 464
 465 (defun
 466  parse-declarations
 467  (tail locals)
 468
 469  ;; Extract the declarations from the head of TAIL and divide them into 2
 470  ;; classes: declares about variables in the list LOCALS, and all other
 471  ;; declarations. Returns 3 values: those 2 lists plus the remainder of TAIL.
 472  (let
 473   (localdecls otherdecls form)
 474   (loop
 475    (unless (and tail (consp (setq form (car tail)))
 476                 (eq (car form)
 477                     'declare))
 478        (return (values localdecls otherdecls tail)))
 479    (mapc
 480     #'(lambda
 481        (decl)
 482        (case (first decl)
 483            ((inline notinline optimize)
 484                                                ; These don't talk about vars
 485               (push decl otherdecls))
 486            (t                             ; Assume all other kinds are
 487                                                ; for vars
 488               (let* ((vars (if (eq (first decl)
 489                                    'type)
 490                                (cddr decl)
 491                                (cdr decl)))
 492                      (l (intersection locals vars))
 493                      other)
 494                     (cond
 495                      ((null l)
 496                                                ; None talk about LOCALS
 497                       (push decl otherdecls))
 498                      ((null (setq other (set-difference vars l)))
 499                                                ; All talk about LOCALS
 500                       (push decl localdecls))
 501                      (t                 ; Some of each
 502                         (let ((head (cons 'type (and (eq (first decl)
 503                                                          'type)
 504                                                      (list (second decl))))))
 505                              (push (append head other)
 506                                    otherdecls)
 507                              (push (append head l)
 508                                    localdecls))))))))
 509     (cdr form))
 510    (pop tail))))
 511
 512 (defun extract-special-bindings (vars decls)
 513
 514        ;; Return the subset of VARS that are special, either globally or
 515        ;; because of a declaration in DECLS
 516        (let ((specials (remove-if-not #'var-globally-special-p vars)))
 517             (dolist (d decls)
 518                 (when (eq (car d)
 519                           'special)
 520                     (setq specials (union specials (intersection vars
 521                                                           (cdr d))))))
 522             specials))
 523
 524 (defun function-lambda-p (form &optional nargs)
 525
 526        ;; If FORM is #'(LAMBDA bindings . body) and bindings is of length
 527        ;; NARGS, return the lambda expression
 528        (let (args body)
 529             (and (consp form)
 530                  (eq (car form)
 531                      'function)
 532                  (consp (setq form (cdr form)))
 533                  (null (cdr form))
 534                  (consp (setq form (car form)))
 535                  (eq (car form)
 536                      'lambda)
 537                  (consp (setq body (cdr form)))
 538                  (listp (setq args (car body)))
 539                  (or (null nargs)
 540                      (eql (length args)
 541                           nargs))
 542                  form)))
 543
 544 (defun
 545  rename-let-bindings
 546  (let-bindings binding-type env leftover-body &optional tempvarfn)
 547
 548  ;; Perform the alpha conversion required for "LET eversion" of
 549  ;; (LET[*] LET-BINDINGS . body)--rename each of the variables to an
 550  ;; internal name. Returns 2 values: a new set of LET bindings and the
 551  ;; alist of old var names to new (so caller can walk the body doing
 552  ;; the rest of the renaming). BINDING-TYPE is one of LET or LET*.
 553  ;; LEFTOVER-BODY is optional list of forms that must be eval'ed
 554  ;; before the first binding happens. ENV is the macro expansion
 555  ;; environment, in case we have to walk a LET*. TEMPVARFN is a
 556  ;; function of no args to return a temporary var; if omitted, we use
 557  ;; GENSYM.
 558  (let
 559   (renamed-vars)
 560   (values (mapcar #'(lambda (binding)
 561                            (let ((valueform (cond ((not (consp binding))
 562
 563                                                ; No initial value
 564                                                    nil)
 565                                                   ((or (eq binding-type
 566                                                            'let)
 567                                                        (null renamed-vars))
 568
 569                                                ; All bindings are in parallel,
 570                                                ; so none can refer to others
 571                                                    (second binding))
 572                                                   (t
 573                                                ; In a LET*, have to substitute
 574                                                ; vars in the 2nd and
 575                                                ; subsequent initialization
 576                                                ; forms
 577                                                      (rename-variables
 578                                                       (second binding)
 579                                                       renamed-vars env))))
 580                                  (newvar (if tempvarfn
 581                                              (funcall tempvarfn)
 582                                              (gensym))))
 583                                 (push (cons (if (consp binding)
 584                                                 (first binding)
 585                                                 binding)
 586                                             newvar)
 587                                       renamed-vars)
 588                                                ; Add new variable to the list
 589                                                ; AFTER we have walked the
 590                                                ; initial value form
 591                                 (when leftover-body
 592                                   ;; Previous clause had some computation to do
 593                                   ;; after its bindings. Here is the first
 594                                   ;; opportunity to do it
 595                                   (setq valueform `(progn ,@leftover-body
 596                                                           ,valueform))
 597                                   (setq leftover-body nil))
 598                                 (list newvar valueform)))
 599                  let-bindings)
 600          renamed-vars)))
 601
 602 (defun rename-variables (form alist env)
 603
 604        ;; Walks FORM, renaming occurrences of the key variables in ALIST with
 605        ;; their corresponding values. ENV is FORM's environment, so we can
 606        ;; make sure we are talking about the same variables.
 607        (walk-form form env
 608               #'(lambda (form context subenv)
 609                        (declare (ignore context))
 610                        (let (pair)
 611                             (cond ((and (symbolp form)
 612                                         (setq pair (assoc form alist))
 613                                         (var-same-p form subenv env))
 614                                    (cdr pair))
 615                                   (t form))))))
 616
 617 (defun
 618  mv-setq
 619  (vars expr)
 620
 621  ;; Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some
 622  ;; of the simple cases for benefit of compilers that don't, and I don't care
 623  ;; what the value is, and I know that the variables need not be set in
 624  ;; parallel, since they can't be used free in EXPR
 625  (cond
 626   ((null vars)
 627                                                ; EXPR is a side-effect
 628    expr)
 629   ((not (consp vars))
 630                                                ; This is an error, but I'll
 631                                                ; let MULTIPLE-VALUE-SETQ
 632                                                ; report it
 633    `(multiple-value-setq ,vars ,expr))
 634   ((and (listp expr)
 635         (eq (car expr)
 636             'values))
 637
 638    ;; (mv-setq (a b c) (values x y z)) can be reduced to a parallel setq
 639    ;; (psetq returns nil, but I don't care about returned value). Do this
 640    ;; even for the single variable case so that we catch (mv-setq (a) (values
 641    ;; x y))
 642    (pop expr)
 643                                                ; VALUES
 644    `(setq ,@(mapcon #'(lambda (tail)
 645                              (list (car tail)
 646                                    (cond ((or (cdr tail)
 647                                               (null (cdr expr)))
 648                                                ; One result expression for
 649                                                ; this var
 650                                           (pop expr))
 651                                          (t    ; More expressions than vars,
 652                                                ; so arrange to evaluate all
 653                                                ; the rest now.
 654                                             (cons 'prog1 expr)))))
 655                    vars)))
 656   ((null (cdr vars))
 657                                                ; Simple one variable case
 658    `(setq ,(car vars)
 659           ,expr))
 660   (t                                       ; General case--I know nothing
 661      `(multiple-value-setq ,vars ,expr))))
 662
 663 (defun var-same-p (var env1 env2)
 664   (eq (var-lexical-p var env1)
 665       (var-lexical-p var env2)))
 666
 667 (defun maybe-warn (type &rest warn-args)
 668
 669        ;; Issue a warning about not being able to optimize this thing. TYPE
 670        ;; is one of :DEFINITION, meaning the definition is at fault, and
 671        ;; :USER, meaning the user's code is at fault.
 672        (when (case *iterate-warnings*
 673                  ((nil) nil)
 674                  ((:user) (eq type :user))
 675                  (t t))
 676            (apply #'warn warn-args)))
 677
 678 ;;; sample iterators
 679 ;;;
 680 ;;; FIXME: If they're only samples, can they be commented out?
 681
 682 (defmacro
 683  interval
 684  (&whole whole &key from downfrom to downto above below by type)
 685  (cond
 686   ((and from downfrom)
 687    (error "Can't use both FROM and DOWNFROM in ~S" whole))
 688   ((cdr (remove nil (list to downto above below)))
 689    (error "Can't use more than one limit keyword in ~S" whole))
 690   (t
 691    (let*
 692     ((down (or downfrom downto above))
 693      (limit (or to downto above below))
 694      (inc (cond ((null by)
 695                  1)
 696                 ((constantp by)
 697                                                ; Can inline this increment
 698                  by))))
 699     `(let
 700       ((from ,(or from downfrom 0))
 701        ,@(and limit `((to ,limit)))
 702        ,@(and (null inc)
 703               `((by ,by))))
 704       ,@(and type `((declare (type ,type from ,@(and limit '(to))
 705                                    ,@(and (null inc)
 706                                           `(by))))))
 707       #'(lambda
 708          (finish)
 709          ,@(cond ((null limit)
 710                                                ; We won't use the FINISH arg.
 711                   '((declare (ignore finish)))))
 712          (prog1 ,(cond (limit             ; Test the limit. If ok,
 713                                                ; return current value and
 714                                                ; increment, else quit
 715                               `(if (,(cond (above '>)
 716                                            (below '<)
 717                                            (down '>=)
 718                                            (t '<=))
 719                                     from to)
 720                                    from
 721                                    (funcall finish)))
 722                        (t                     ; No test
 723                           'from))
 724              (setq from (,(if down
 725                               '-
 726                               '+)
 727                          from
 728                          ,(or inc 'by))))))))))
 729
 730 (defmacro list-elements (list &key (by '#'cdr))
 731        `(let ((tail ,list))
 732              #'(lambda (finish)
 733                       (prog1 (if (endp tail)
 734                                  (funcall finish)
 735                                  (first tail))
 736                           (setq tail (funcall ,by tail))))))
 737
 738 (defmacro list-tails (list &key (by '#'cdr))
 739        `(let ((tail ,list))
 740              #'(lambda (finish)
 741                       (prog1 (if (endp tail)
 742                                  (funcall finish)
 743                                  tail)
 744                           (setq tail (funcall ,by tail))))))
 745
 746 (defmacro
 747  elements
 748  (sequence)
 749  "Generates successive elements of SEQUENCE, with second value being the index. Use (ELEMENTS (THE type arg)) if you care about the type."
 750  (let*
 751   ((type (and (consp sequence)
 752               (eq (first sequence)
 753                   'the)
 754               (second sequence)))
 755    (accessor (if type
 756                  (sequence-accessor type)
 757                  'elt))
 758    (listp (eq type 'list)))
 759
 760   ;; If type is given via THE, we may be able to generate a good accessor here
 761   ;; for the benefit of implementations that aren't smart about (ELT (THE
 762   ;; STRING FOO)). I'm not bothering to keep the THE inside the body,
 763   ;; however, since I assume any compiler that would understand (AREF (THE
 764   ;; SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I
 765   ;; bound S to (THE SIMPLE-ARRAY foo) and never modified it.
 766
 767   ;; If sequence is declared to be a list, it's better to cdr down it, so we
 768   ;; have some extra cases here. Normally folks would write LIST-ELEMENTS,
 769   ;; but maybe they wanted to get the index for free...
 770   `(let* ((index 0)
 771           (s ,sequence)
 772           ,@(and (not listp)
 773                  '((size (length s)))))
 774          #'(lambda (finish)
 775                   (values (cond ,(if listp
 776                                      '((not (endp s))
 777                                        (pop s))
 778                                      `((< index size)
 779                                        (,accessor s index)))
 780                                 (t (funcall finish)))
 781                          (prog1 index
 782                              (setq index (1+ index))))))))
 783
 784 (defmacro
 785  plist-elements
 786  (plist)
 787  "Generates each time 2 items, the indicator and the value."
 788  `(let ((tail ,plist))
 789        #'(lambda (finish)
 790                 (values (if (endp tail)
 791                             (funcall finish)
 792                             (first tail))
 793                        (prog1 (if (endp (setq tail (cdr tail)))
 794                                   (funcall finish)
 795                                   (first tail))
 796                            (setq tail (cdr tail)))))))
 797
 798 (defun sequence-accessor (type)
 799
 800        ;; returns the function with which most efficiently to make accesses to
 801        ;; a sequence of type TYPE.
 802        (case (if (consp type)
 803                                                ; e.g., (VECTOR FLOAT *)
 804                  (car type)
 805                  type)
 806            ((array simple-array vector) 'aref)
 807            (simple-vector 'svref)
 808            (string 'char)
 809            (simple-string 'schar)
 810            (bit-vector 'bit)
 811            (simple-bit-vector 'sbit)
 812            (t 'elt)))
 813
 814 ;; These "iterators" may be withdrawn
 815
 816 (defmacro eachtime (expr)
 817        `#'(lambda (finish)
 818                  (declare (ignore finish))
 819                  ,expr))
 820
 821 (defmacro while (expr)
 822        `#'(lambda (finish)
 823                  (unless ,expr (funcall finish))))
 824
 825 (defmacro until (expr)
 826        `#'(lambda (finish)
 827                  (when ,expr (funcall finish))))
 828
 829                                                ; GATHERING macro
 830
 831 (defmacro gathering (clauses &body body &environment env)
 832        (or (optimize-gathering-form clauses body env)
 833            (simple-expand-gathering-form clauses body env)))
 834
 835 (defmacro with-gathering (clauses gather-body &body use-body)
 836        "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour."
 837
 838        ;; We may optimize this a little better later for those compilers that
 839        ;; don't do a good job on (m-v-bind vars (... (values ...)) ...).
 840        `(multiple-value-bind ,(mapcar #'car clauses)
 841                (gathering ,clauses ,gather-body)
 842                ,@use-body))
 843
 844 (defun
 845  simple-expand-gathering-form
 846  (clauses body env)
 847  (declare (ignore env))
 848
 849  ;; The "formal semantics" of GATHERING. We use this only in cases that can't
 850  ;; be optimized.
 851  (let
 852   ((acc-names (mapcar #'first (if (symbolp clauses)
 853                                                ; Shorthand using anonymous
 854                                                ; gathering site
 855                                   (setq clauses `((*anonymous-gathering-site*
 856                                                    (,clauses))))
 857                                   clauses)))
 858    (realizer-names (mapcar #'(lambda (binding)
 859                                     (declare (ignore binding))
 860                                     (gensym))
 861                           clauses)))
 862   `(multiple-value-call
 863     #'(lambda
 864        ,(mapcan #'list acc-names realizer-names)
 865        (flet ((gather (value &optional (accumulator *anonymous-gathering-site*)
 866                              )
 867                      (funcall accumulator value)))
 868              ,@body
 869              (values ,@(mapcar #'(lambda (rname)
 870                                         `(funcall ,rname))
 871                               realizer-names))))
 872     ,@(mapcar #'second clauses))))
 873
 874 (defvar *active-gatherers* nil
 875        "List of GATHERING bindings currently active during macro expansion)")
 876
 877 (defvar *anonymous-gathering-site* nil "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site).")
 878
 879 (defun optimize-gathering-form (clauses body gathering-env)
 880  (let*
 881   (acc-info leftover-body top-bindings finish-forms top-decls)
 882   (dolist (clause (if (symbolp clauses)
 883                                                ; a shorthand
 884                       `((*anonymous-gathering-site* (,clauses)))
 885                       clauses))
 886       (multiple-value-bind
 887        (let-body binding-type let-bindings localdecls otherdecls extra-body)
 888        (expand-into-let (second clause)
 889               'gathering gathering-env)
 890        (prog*
 891         ((acc-var (first clause))
 892          renamed-vars accumulator realizer)
 893         (when (and (consp let-body)
 894                    (eq (car let-body)
 895                        'values)
 896                    (consp (setq let-body (cdr let-body)))
 897                    (setq accumulator (function-lambda-p (car let-body)))
 898                    (consp (setq let-body (cdr let-body)))
 899                    (setq realizer (function-lambda-p (car let-body)
 900                                          0))
 901                    (null (cdr let-body)))
 902
 903             ;; Macro returned something of the form
 904             ;;   (VALUES #'(lambda (value) ...)
 905             ;;     #'(lambda () ...)),
 906             ;; a function to accumulate values and a function to realize the
 907             ;; result.
 908             (when binding-type
 909
 910                 ;; Gatherer expanded into a LET
 911                 (cond (otherdecls (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S"
 912                                          (second clause)
 913                                          `(declare ,@otherdecls))
 914                              (go punt)))
 915                 (when let-bindings
 916
 917                     ;; The first transformation we want to perform is a
 918                     ;; variant of "LET-eversion": turn
 919                     ;;   (mv-bind
 920                     ;;       (acc real)
 921                     ;;       (let (..bindings..)
 922                     ;;   (values #'(lambda ...)
 923                     ;;           #'(lambda ...)))
 924                     ;;     ..body..)
 925                     ;; into
 926                     ;;   (let* (..bindings..
 927                     ;;    (acc #'(lambda ...))
 928                     ;;    (real #'(lambda ...)))
 929                     ;;     ..body..).
 930                     ;; This transformation is valid if nothing in body refers
 931                     ;; to any of the bindings, something we can ensure by
 932                     ;; alpha-converting the inner let (substituting new names
 933                     ;; for each var). Of course, none of those vars can be
 934                     ;; special, but we already checked for that above.
 935                     (multiple-value-setq (let-bindings renamed-vars)
 936                            (rename-let-bindings let-bindings binding-type
 937                                   gathering-env leftover-body))
 938                     (setq top-bindings (nconc top-bindings let-bindings))
 939                     (setq leftover-body nil)
 940                                                ; If there was any leftover
 941                                                ; from previous, it is now
 942                                                ; consumed
 943                     ))
 944             (setq leftover-body (nconc leftover-body extra-body))
 945                                                ; Computation to do after these
 946                                                ; bindings
 947             (push (cons acc-var (rename-and-capture-variables accumulator
 948                                        renamed-vars gathering-env))
 949                   acc-info)
 950             (setq realizer (rename-variables realizer renamed-vars
 951                                   gathering-env))
 952             (push (cond ((null (cdddr realizer))
 953                                                ; Simple (LAMBDA () expr) =>
 954                                                ; expr
 955                          (third realizer))
 956                         (t                   ; There could be declarations
 957                                                ; or something, so leave as a
 958                                                ; LET
 959                            (cons 'let (cdr realizer))))
 960                   finish-forms)
 961             (unless (null localdecls)
 962                                                ; Declarations about the LET
 963                                                ; variables also has to
 964                                                ; percolate up
 965                 (setq top-decls (nconc top-decls (sublis renamed-vars
 966                                                         localdecls))))
 967             (return))
 968         (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))"
 969                (second clause))
 970         punt
 971         (let
 972          ((gs (gensym))
 973           (expansion `(multiple-value-list ,(second clause))))
 974                                                ; Slow way--bind gensym to the
 975                                                ; macro expansion, and we will
 976                                                ; funcall it in the body
 977          (push (list acc-var gs)
 978                acc-info)
 979          (push `(funcall (cadr ,gs))
 980                finish-forms)
 981          (setq
 982           top-bindings
 983           (nconc
 984            top-bindings
 985            (list (list gs (cond (leftover-body
 986                                  `(progn ,@(prog1 leftover-body
 987                                                   (setq leftover-body nil))
 988                                          ,expansion))
 989                                 (t expansion))))))))))
 990   (setq body (walk-gathering-body body gathering-env acc-info))
 991   (cond ((eq body :abort)
 992                                                ; Couldn't finish expansion
 993          nil)
 994         (t `(let* ,top-bindings
 995                   ,@(and top-decls `((declare ,@top-decls)))
 996                   ,body
 997                   ,(cond ((null (cdr finish-forms))
 998                                                ; just a single value
 999                           (car finish-forms))
1000                          (t `(values ,@(reverse finish-forms)))))))))
1001
1002 (defun rename-and-capture-variables (form alist env)
1003
1004        ;; Walks FORM, renaming occurrences of the key variables in ALIST with
1005        ;; their corresponding values, and capturing any other free variables.
1006        ;; Returns a list of the new form and the list of other closed-over
1007        ;; vars. ENV is FORM's environment, so we can make sure we are talking
1008        ;; about the same variables.
1009        (let (closed)
1010             (list (walk-form
1011                    form env
1012                    #'(lambda (form context subenv)
1013                             (declare (ignore context))
1014                             (let (pair)
1015                                  (cond ((or (not (symbolp form))
1016                                             (not (var-same-p form subenv env)))
1017                                                ; non-variable or one that has
1018                                                ; been rebound
1019                                         form)
1020                                        ((setq pair (assoc form alist))
1021                                                ; One to rename
1022                                         (cdr pair))
1023                                        (t      ; var is free
1024                                           (pushnew form closed)
1025                                           form)))))
1026                   closed)))
1027
1028 (defun
1029  walk-gathering-body
1030  (body gathering-env acc-info)
1031
1032  ;; Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV.
1033  ;; ACC-INFO is a list of information about each of the gathering "bindings"
1034  ;; in the form, in the form (var gatheringfn freevars env)
1035  (let
1036   ((*active-gatherers* (nconc (mapcar #'car acc-info)
1037                               *active-gatherers*)))
1038
1039   ;; *ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER
1040   ;; targets. This is so that when we encounter a GATHER not belonging to us
1041   ;; we can know whether to warn about it.
1042   (walk-form
1043    (cons 'progn body)
1044    gathering-env
1045    #'(lambda
1046       (form context env)
1047       (declare (ignore context))
1048       (let (info site)
1049            (cond ((consp form)
1050                   (cond
1051                    ((not (eq (car form)
1052                              'gather))
1053                                                ; We only care about GATHER
1054                     (when (and (eq (car form)
1055                                    'function)
1056                                (eq (cadr form)
1057                                    'gather))
1058                                                ; Passed as functional--can't
1059                                                ; macroexpand
1060                         (maybe-warn :user
1061                    "Can't optimize GATHERING because of reference to #'GATHER."
1062                                )
1063                         (return-from walk-gathering-body :abort))
1064                     form)
1065                    ((setq info (assoc (setq site (if (null (cddr form))
1066
1067                                                      '
1068                                                      *anonymous-gathering-site*
1069                                                      (third form)))
1070                                       acc-info))
1071                                                ; One of ours--expand (GATHER
1072                                                ; value var). INFO = (var
1073                                                ; gatheringfn freevars env)
1074                     (unless (null (cdddr form))
1075                            (warn "Extra arguments (> 2) in ~S discarded." form)
1076                            )
1077                     (let ((fn (second info)))
1078                          (cond ((symbolp fn)
1079                                                ; Unoptimized case--just call
1080                                                ; the gatherer. FN is the
1081                                                ; gensym that we bound to the
1082                                                ; list of two values returned
1083                                                ; from the gatherer.
1084                                 `(funcall (car ,fn)
1085                                         ,(second form)))
1086                                (t             ; FN = (lambda (value) ...)
1087                                   (dolist (s (third info))
1088                                       (unless (or (var-same-p s env
1089                                                               gathering-env)
1090                                                   (and (var-special-p
1091                                                         s env)
1092                                                        (var-special-p
1093                                                         s gathering-env)))
1094
1095                           ;; Some var used free in the LAMBDA form has been
1096                           ;; rebound between here and the parent GATHERING
1097                           ;; form, so can't substitute the lambda. Ok if it's
1098                           ;; a special reference both here and in the LAMBDA,
1099                           ;; because then it's not closed over.
1100                                           (maybe-warn :user "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it."
1101                                                  s)
1102                                           (return-from walk-gathering-body
1103                                                  :abort)))
1104
1105                           ;; Return ((lambda (value) ...) actual-value). In
1106                           ;; many cases we could simplify this further by
1107                           ;; substitution, but we'd have to be careful (for
1108                           ;; example, we would need to alpha-convert any LET
1109                           ;; we found inside). Any decent compiler will do it
1110                           ;; for us.
1111                                   (list fn (second form))))))
1112                    ((and (setq info (member site *active-gatherers*))
1113                          (or (eq site '*anonymous-gathering-site*)
1114                              (var-same-p site env (fourth info))))
1115                                                ; Some other GATHERING will
1116                                                ; take care of this form, so
1117                                                ; pass it up for now.
1118                                                ; Environment check is to make
1119                                                ; sure nobody shadowed it
1120                                                ; between here and there
1121                     form)
1122                    (t                     ; Nobody's going to handle it
1123                       (if (eq site '*anonymous-gathering-site*)
1124                                                ; More likely that she forgot
1125                                                ; to mention the site than
1126                                                ; forget to write an anonymous
1127                                                ; gathering.
1128                           (warn "There is no gathering site specified in ~S."
1129                                 form)
1130                           (warn
1131              "The site ~S in ~S is not defined in an enclosing GATHERING form."
1132                                 site form))
1133                                                ; Turn it into something else
1134                                                ; so we don't warn twice in the
1135                                                ; nested case
1136                       `(%orphaned-gather ,@(cdr form)))))
1137                  ((and (symbolp form)
1138                        (setq info (assoc form acc-info))
1139                        (var-same-p form env gathering-env))
1140                                                ; A variable reference to a
1141                                                ; gather binding from
1142                                                ; environment TEM
1143                   (maybe-warn :user "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form."
1144                          form)
1145                   (return-from walk-gathering-body :abort))
1146                  (t form)))))))
1147
1148 ;; sample gatherers
1149 ;;
1150 ;; FIXME: If these are only samples, can we delete them?
1151
1152 (defmacro
1153  collecting
1154  (&key initial-value)
1155  `(let* ((head ,initial-value)
1156          (tail ,(and initial-value `(last head))))
1157         (values #'(lambda (value)
1158                          (if (null head)
1159                              (setq head (setq tail (list value)))
1160                              (setq tail (cdr (rplacd tail (list value))))))
1161                #'(lambda nil head))))
1162
1163 (defmacro joining (&key initial-value)
1164        `(let ((result ,initial-value))
1165              (values #'(lambda (value)
1166                               (setq result (nconc result value)))
1167                     #'(lambda nil result))))
1168
1169 (defmacro
1170  maximizing
1171  (&key initial-value)
1172  `(let ((result ,initial-value))
1173        (values
1174         #'(lambda (value)
1175                  (when ,(cond ((and (constantp initial-value)
1176                                     (not (null (eval initial-value))))
1177                                                ; Initial value is given and we
1178                                                ; know it's not NIL, so leave
1179                                                ; out the null check
1180                                '(> value result))
1181                               (t '(or (null result)
1182                                       (> value result))))
1183                        (setq result value)))
1184         #'(lambda nil result))))
1185
1186 (defmacro
1187  minimizing
1188  (&key initial-value)
1189  `(let ((result ,initial-value))
1190        (values
1191         #'(lambda (value)
1192                  (when ,(cond ((and (constantp initial-value)
1193                                     (not (null (eval initial-value))))
1194                                                ; Initial value is given and we
1195                                                ; know it's not NIL, so leave
1196                                                ; out the null check
1197                                '(< value result))
1198                               (t '(or (null result)
1199                                       (< value result))))
1200                        (setq result value)))
1201         #'(lambda nil result))))
1202
1203 (defmacro summing (&key (initial-value 0))
1204   `(let ((sum ,initial-value))
1205      (values #'(lambda (value)
1206                  (setq sum (+ sum value)))
1207              #'(lambda nil sum))))
1208
1209 ;;; It's easier to read expanded code if PROG1 gets left alone.
1210 (define-walker-template prog1 (nil return sb-walker::repeat (eval)))