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