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