src/pcl/iterate.lisp

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