auxfns.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
   2 ;;; Code from Paradigms of AI Programming
   3 ;;; Copyright (c) 1991 Peter Norvig
   4
   5 ;;; File auxfns.lisp: Auxiliary functions used by all other programs
   6 ;;; Load this file before running any other programs.
   7
   8 ;;;; Implementation-Specific Details
   9
  10 (in-package :cl-tuples)
  11
  12 (eval-when (eval compile load)
  13 ;;  Make it ok to place a function definition on a built-in LISP symbol.
  14   #+allegro
  15   (dolist (pkg '(excl common-lisp common-lisp-user))
  16     (setf (excl:package-definition-lock (find-package pkg)) nil))
  17   #+clisp
  18   (dolist (pkg '(excl common-lisp common-lisp-user))
  19     (setf (ext:package-lock (find-package pkg)) nil))
  20   #+sbcl
  21   (dolist (pkg '(common-lisp common-lisp-user))
  22     (sb-ext:unlock-package (find-package pkg)))
  23   #+cmu
  24   (dolist (pkg '(extensions common-lisp common-lisp-user))
  25     (let ((pkg (find-package pkg)))
  26       (when pkg
  27         (setf (ext:package-lock pkg) nil)
  28         (setf (ext:package-definition-lock pkg) nil))))
  29
  30 ;;   Don't warn if a function is defined in multiple files --
  31 ;;   this happens often since we refine several programs.
  32   #+Lispworks
  33   (setq *PACKAGES-FOR-WARN-ON-REDEFINITION* nil)
  34
  35   #+LCL
  36    (compiler-options :warnings nil)
  37   )
  38
  39 ;;;; Macros (formerly in auxmacs.lisp: that file no longer needed)
  40
  41 (eval-when (load eval compile)
  42
  43 ;;   (defmacro once-only (variables &rest body)
  44 ;;     "Returns the code built by BODY.  If any of VARIABLES
  45 ;;   might have side effects, they are evaluated once and stored
  46 ;;   in temporary variables that are then passed to BODY."
  47 ;;     (assert (every #'symbolp variables))
  48 ;;     (let ((temps nil))
  49 ;;       (dotimes (i (length variables)) (push (gensym) temps))
  50 ;;       `(if (every #'side-effect-free? (list .,variables))
  51 ;;      (progn .,body)
  52 ;;      (list 'let
  53 ;;       ,`(list ,@(mapcar #'(lambda (tmp var)
  54 ;;                             `(list ',tmp ,var))
  55 ;;                         temps variables))
  56 ;;       (let ,(mapcar #'(lambda (var tmp) `(,var ',tmp))
  57 ;;                     variables temps)
  58 ;;         .,body)))))
  59
  60   (defun side-effect-free? (exp)
  61     "Is exp a constant, variable, or function,
  62   or of the form (THE type x) where x is side-effect-free?"
  63     (or (atom exp) (constantp exp)
  64         (starts-with exp 'function)
  65         (and (starts-with exp 'the)
  66              (side-effect-free? (third exp)))))
  67
  68   (defmacro funcall-if (fn arg)
  69     (once-only (fn)
  70                `(if ,fn (funcall ,fn ,arg) ,arg)))
  71
  72   (defmacro read-time-case (first-case &rest other-cases)
  73     "Do the first case, where normally cases are
  74   specified with #+ or possibly #- marks."
  75     (declare (ignore other-cases))
  76     first-case)
  77
  78   (defun rest2 (x)
  79     "The rest of a list after the first TWO elements."
  80     (rest (rest x)))
  81
  82   (defun find-anywhere (item tree)
  83     "Does item occur anywhere in tree?"
  84     (if (atom tree)
  85         (if (eql item tree) tree)
  86         (or (find-anywhere item (first tree))
  87             (find-anywhere item (rest tree)))))
  88
  89   (defun starts-with (list x)
  90     "Is x a list whose first element is x?"
  91     (and (consp list) (eql (first list) x)))
  92   )
  93
  94 ;;;; Auxiliary Functions
  95
  96 (setf (symbol-function 'find-all-if) #'remove-if-not)
  97
  98 (defun find-all (item sequence &rest keyword-args
  99                  &key (test #'eql) test-not &allow-other-keys)
 100   "Find all those elements of sequence that match item,
 101   according to the keywords.  Doesn't alter sequence."
 102   (if test-not
 103       (apply #'remove item sequence
 104              :test-not (complement test-not) keyword-args)
 105       (apply #'remove item sequence
 106              :test (complement test) keyword-args)))
 107
 108 (defun partition-if (pred list)
 109   "Return 2 values: elements of list that satisfy pred,
 110   and elements that don't."
 111   (let ((yes-list nil)
 112         (no-list nil))
 113     (dolist (item list)
 114       (if (funcall pred item)
 115           (push item yes-list)
 116           (push item no-list)))
 117     (values (nreverse yes-list) (nreverse no-list))))
 118
 119 (defun maybe-add (op exps &optional if-nil)
 120   "For example, (maybe-add 'and exps t) returns
 121   t if exps is nil, exps if there is only one,
 122   and (and exp1 exp2...) if there are several exps."
 123   (cond ((null exps) if-nil)
 124         ((length=1 exps) (first exps))
 125         (t (cons op exps))))
 126
 127 ;;; ==============================
 128
 129 (defun seq-ref (seq index)
 130   "Return code that indexes into a sequence, using
 131   the pop-lists/aref-vectors strategy."
 132   `(if (listp ,seq)
 133        (prog1 (first ,seq)
 134               (setq ,seq (the list (rest ,seq))))
 135        (aref ,seq ,index)))
 136
 137 (defun maybe-set-fill-pointer (array new-length)
 138   "If this is an array with a fill pointer, set it to
 139   new-length, if that is longer than the current length."
 140   (if (and (arrayp array)
 141            (array-has-fill-pointer-p array))
 142       (setf (fill-pointer array)
 143             (max (fill-pointer array) new-length))))
 144
 145 ;;; ==============================
 146
 147 ;;; NOTE: In ANSI Common Lisp, the effects of adding a definition (or most
 148 ;;; anything else) to a symbol in the common-lisp package is undefined.
 149 ;;; Therefore, it would be best to rename the function SYMBOL to something
 150 ;;; else.  This has not been done (for compatibility with the book).
 151
 152 (defun symbol (&rest args)
 153   "Concatenate symbols or strings to form an interned symbol"
 154   (intern (format nil "~{~a~}" args)))
 155
 156 (defun new-symbol (&rest args)
 157   "Concatenate symbols or strings to form an uninterned symbol"
 158   (make-symbol (format nil "~{~a~}" args)))
 159
 160 (defun last1 (list)
 161   "Return the last element (not last cons cell) of list"
 162   (first (last list)))
 163
 164 ;;; ==============================
 165
 166 (defun mappend (fn list)
 167   "Append the results of calling fn on each element of list.
 168   Like mapcon, but uses append instead of nconc."
 169   (apply #'append (mapcar fn list)))
 170
 171 (defun mklist (x)
 172   "If x is a list return it, otherwise return the list of x"
 173   (if (listp x) x (list x)))
 174
 175 (defun flatten (exp)
 176   "Get rid of imbedded lists (to one level only)."
 177   (mappend #'mklist exp))
 178
 179 (defun random-elt (seq)
 180   "Pick a random element out of a sequence."
 181   (elt seq (random (length seq))))
 182
 183 ;;; ==============================
 184
 185 (defun member-equal (item list)
 186   (member item list :test #'equal))
 187
 188 ;;; ==============================
 189
 190 (defun compose (&rest functions)
 191   #'(lambda (x)
 192       (reduce #'funcall functions :from-end t :initial-value x)))
 193
 194 ;;;; The Debugging Output Facility:
 195
 196 (defvar *dbg-ids* nil "Identifiers used by dbg")
 197
 198 (defun dbg (id format-string &rest args)
 199   "Print debugging info if (DEBUG ID) has been specified."
 200   (when (member id *dbg-ids*)
 201     (fresh-line *debug-io*)
 202     (apply #'format *debug-io* format-string args)))
 203
 204 (defun debug (&rest ids)
 205   "Start dbg output on the given ids."
 206   (setf *dbg-ids* (union ids *dbg-ids*)))
 207
 208 (defun undebug (&rest ids)
 209   "Stop dbg on the ids.  With no ids, stop dbg altogether."
 210   (setf *dbg-ids* (if (null ids) nil
 211                       (set-difference *dbg-ids* ids))))
 212
 213 ;;; ==============================
 214
 215 (defun dbg-indent (id indent format-string &rest args)
 216   "Print indented debugging info if (DEBUG ID) has been specified."
 217   (when (member id *dbg-ids*)
 218     (fresh-line *debug-io*)
 219     (dotimes (i indent) (princ "  " *debug-io*))
 220     (apply #'format *debug-io* format-string args)))
 221
 222 ;;;; PATTERN MATCHING FACILITY
 223
 224 (defconstant fail nil)
 225 (defparameter no-bindings '((t . t)))
 226
 227 (defun pat-match (pattern input &optional (bindings no-bindings))
 228   "Match pattern against input in the context of the bindings"
 229   (cond ((eq bindings fail) fail)
 230         ((variable-p pattern) (match-variable pattern input bindings))
 231         ((eql pattern input) bindings)
 232         ((and (consp pattern) (consp input))
 233          (pat-match (rest pattern) (rest input)
 234                     (pat-match (first pattern) (first input) bindings)))
 235         (t fail)))
 236
 237 (defun match-variable (var input bindings)
 238   "Does VAR match input?  Uses (or updates) and returns bindings."
 239   (let ((binding (get-binding var bindings)))
 240     (cond ((not binding) (extend-bindings var input bindings))
 241           ((equal input (binding-val binding)) bindings)
 242           (t fail))))
 243
 244 (defun make-binding (var val) (cons var val))
 245
 246 (defun binding-var (binding)
 247   "Get the variable part of a single binding."
 248   (car binding))
 249
 250 (defun binding-val (binding)
 251   "Get the value part of a single binding."
 252   (cdr binding))
 253
 254 (defun get-binding (var bindings)
 255   "Find a (variable . value) pair in a binding list."
 256   (assoc var bindings))
 257
 258 (defun lookup (var bindings)
 259   "Get the value part (for var) from a binding list."
 260   (binding-val (get-binding var bindings)))
 261
 262 (defun extend-bindings (var val bindings)
 263   "Add a (var . value) pair to a binding list."
 264   (cons (cons var val)
 265         ;; Once we add a "real" binding,
 266         ;; we can get rid of the dummy no-bindings
 267         (if (eq bindings no-bindings)
 268             nil
 269             bindings)))
 270
 271 (defun variable-p (x)
 272   "Is x a variable (a symbol beginning with `?')?"
 273   (and (symbolp x) (equal (elt (symbol-name x) 0) #\?)))
 274
 275 ;;; ==============================
 276
 277 ;;;; The Memoization facility:
 278
 279 (defmacro defun-memo (fn args &body body)
 280   "Define a memoized function."
 281   `(memoize (defun ,fn ,args . ,body)))
 282
 283 (defun memo (fn &key (key #'first) (test #'eql) name)
 284   "Return a memo-function of fn."
 285   (let ((table (make-hash-table :test test)))
 286     (setf (get name 'memo) table)
 287     #'(lambda (&rest args)
 288         (let ((k (funcall key args)))
 289           (multiple-value-bind (val found-p)
 290               (gethash k table)
 291             (if found-p val
 292                 (setf (gethash k table) (apply fn args))))))))
 293
 294 (defun memoize (fn-name &key (key #'first) (test #'eql))
 295   "Replace fn-name's global definition with a memoized version."
 296   (clear-memoize fn-name)
 297   (setf (symbol-function fn-name)
 298         (memo (symbol-function fn-name)
 299               :name fn-name :key key :test test)))
 300
 301 (defun clear-memoize (fn-name)
 302   "Clear the hash table from a memo function."
 303   (let ((table (get fn-name 'memo)))
 304     (when table (clrhash table))))
 305
 306 ;;;; Delayed computation:
 307
 308 (defstruct delay value (computed? nil))
 309
 310 (defmacro delay (&rest body)
 311   "A computation that can be executed later by FORCE."
 312   `(make-delay :value #'(lambda () . ,body)))
 313
 314 (defun force (delay)
 315   "Do a delayed computation, or fetch its previously-computed value."
 316   (if (delay-computed? delay)
 317       (delay-value delay)
 318       (prog1 (setf (delay-value delay) (funcall (delay-value delay)))
 319              (setf (delay-computed? delay) t))))
 320
 321 ;;;; Defresource:
 322
 323 (defmacro defresource (name &key constructor (initial-copies 0)
 324                        (size (max initial-copies 10)))
 325   (let ((resource (symbol '* (symbol name '-resource*)))
 326         (deallocate (symbol 'deallocate- name))
 327         (allocate (symbol 'allocate- name)))
 328     `(progn
 329        (defparameter ,resource (make-array ,size :fill-pointer 0))
 330        (defun ,allocate ()
 331          "Get an element from the resource pool, or make one."
 332          (if (= (fill-pointer ,resource) 0)
 333              ,constructor
 334              (vector-pop ,resource)))
 335        (defun ,deallocate (,name)
 336          "Place a no-longer-needed element back in the pool."
 337          (vector-push-extend ,name ,resource))
 338        ,(if (> initial-copies 0)
 339             `(mapc #',deallocate (loop repeat ,initial-copies
 340                                        collect (,allocate))))
 341        ',name)))
 342
 343 (defmacro with-resource ((var resource &optional protect) &rest body)
 344   "Execute body with VAR bound to an instance of RESOURCE."
 345   (let ((allocate (symbol 'allocate- resource))
 346         (deallocate (symbol 'deallocate- resource)))
 347     (if protect
 348         `(let ((,var nil))
 349            (unwind-protect (progn (setf ,var (,allocate)) ,@body)
 350              (unless (null ,var) (,deallocate ,var))))
 351         `(let ((,var (,allocate)))
 352            ,@body
 353            (,deallocate var)))))
 354
 355 ;;;; Queues:
 356
 357 ;;; A queue is a (last . contents) pair
 358
 359 (defun queue-contents (q) (cdr q))
 360
 361 (defun make-queue ()
 362   "Build a new queue, with no elements."
 363   (let ((q (cons nil nil)))
 364     (setf (car q) q)))
 365
 366 (defun enqueue (item q)
 367   "Insert item at the end of the queue."
 368   (setf (car q)
 369         (setf (rest (car q))
 370               (cons item nil)))
 371   q)
 372
 373 (defun dequeue (q)
 374   "Remove an item from the front of the queue."
 375   (pop (cdr q))
 376   (if (null (cdr q)) (setf (car q) q))
 377   q)
 378
 379 (defun front (q) (first (queue-contents q)))
 380
 381 (defun empty-queue-p (q) (null (queue-contents q)))
 382
 383 (defun queue-nconc (q list)
 384   "Add the elements of LIST to the end of the queue."
 385   (setf (car q)
 386         (last (setf (rest (car q)) list))))
 387
 388 ;;;; Other:
 389
 390 (defun sort* (seq pred &key key)
 391   "Sort without altering the sequence"
 392   (sort (copy-seq seq) pred :key key))
 393
 394 (defun reuse-cons (x y x-y)
 395   "Return (cons x y), or reuse x-y if it is equal to (cons x y)"
 396   (if (and (eql x (car x-y)) (eql y (cdr x-y)))
 397       x-y
 398       (cons x y)))
 399
 400 ;;; ==============================
 401
 402 (defun length=1 (x)
 403   "Is x a list of length 1?"
 404   (and (consp x) (null (cdr x))))
 405
 406 (defun rest3 (list)
 407   "The rest of a list after the first THREE elements."
 408   (cdddr list))
 409
 410 ;;; ==============================
 411
 412 (defun unique-find-if-anywhere (predicate tree
 413                                 &optional found-so-far)
 414   "Return a list of leaves of tree satisfying predicate,
 415   with duplicates removed."
 416   (if (atom tree)
 417       (if (funcall predicate tree)
 418           (adjoin tree found-so-far)
 419           found-so-far)
 420       (unique-find-if-anywhere
 421         predicate
 422         (first tree)
 423         (unique-find-if-anywhere predicate (rest tree)
 424                                  found-so-far))))
 425
 426 (defun find-if-anywhere (predicate tree)
 427   "Does predicate apply to any atom in the tree?"
 428   (if (atom tree)
 429       (funcall predicate tree)
 430       (or (find-if-anywhere predicate (first tree))
 431           (find-if-anywhere predicate (rest tree)))))
 432
 433 ;;; ==============================
 434
 435 (defmacro define-enumerated-type (type &rest elements)
 436   "Represent an enumerated type with integers 0-n."
 437   `(progn
 438      (deftype ,type () '(integer 0 ,(- (length elements) 1)))
 439      (defun ,(symbol type '->symbol) (,type)
 440        (elt ',elements ,type))
 441      (defun ,(symbol 'symbol-> type) (symbol)
 442        (position symbol ',elements))
 443      ,@(loop for element in elements
 444              for i from 0
 445              collect `(defconstant ,element ,i))))
 446
 447 ;;; ==============================
 448
 449 (defun not-null (x) (not (null x)))
 450
 451 (defun first-or-nil (x)
 452   "The first element of x if it is a list; else nil."
 453   (if (consp x) (first x) nil))
 454
 455 (defun first-or-self (x)
 456   "The first element of x, if it is a list; else x itself."
 457   (if (consp x) (first x) x))
 458
 459 ;;; ==============================
 460
 461 ;; ;;;; CLtL2 and ANSI CL Compatibility
 462
 463 ;; (unless (fboundp 'defmethod)
 464 ;; (defmacro defmethod (name args &rest body)
 465 ;;   `(defun ',name ',args ,@body))
 466 ;; )
 467
 468 ;; (unless (fboundp 'map-into)
 469 ;; (defun map-into (result-sequence function &rest sequences)
 470 ;;   "Destructively set elements of RESULT-SEQUENCE to the results
 471 ;;   of applying FUNCTION to respective elements of SEQUENCES."
 472 ;;   (let ((arglist (make-list (length sequences)))
 473 ;;         (n (if (listp result-sequence)
 474 ;;                most-positive-fixnum
 475 ;;                (array-dimension result-sequence 0))))
 476 ;;     ;; arglist is made into a list of args for each call
 477 ;;     ;; n is the length of the longest vector
 478 ;;     (when sequences
 479 ;;       (setf n (min n (loop for seq in sequences
 480 ;;                            minimize (length seq)))))
 481 ;;     ;; Define some shared functions:
 482 ;;     (flet
 483 ;;       ((do-one-call (i)
 484 ;;          (loop for seq on sequences
 485 ;;                for arg on arglist
 486 ;;                do (if (listp (first seq))
 487 ;;                       (setf (first arg)
 488 ;;                             (pop (first seq)))
 489 ;;                       (setf (first arg)
 490 ;;                             (aref (first seq) i))))
 491 ;;          (apply function arglist))
 492 ;;        (do-result (i)
 493 ;;          (if (and (vectorp result-sequence)
 494 ;;                   (array-has-fill-pointer-p result-sequence))
 495 ;;              (setf (fill-pointer result-sequence)
 496 ;;                    (max i (fill-pointer result-sequence))))))
 497 ;;       (declare (inline do-one-call))
 498 ;;       ;; Decide if the result is a list or vector,
 499 ;;       ;; and loop through each element
 500 ;;       (if (listp result-sequence)
 501 ;;           (loop for i from 0 to (- n 1)
 502 ;;                 for r on result-sequence
 503 ;;                 do (setf (first r)
 504 ;;                          (do-one-call i))
 505 ;;                 finally (do-result i))
 506 ;;           (loop for i from 0 to (- n 1)
 507 ;;                 do (setf (aref result-sequence i)
 508 ;;                          (do-one-call i))
 509 ;;                 finally (do-result i))))
 510 ;;       result-sequence))
 511
 512 ;; )
 513
 514 ;; (unless (fboundp 'complement)
 515 ;; (defun complement (fn)
 516 ;;   "If FN returns y, then (complement FN) returns (not y)."
 517 ;;   #'(lambda (&rest args) (not (apply fn args))))
 518 ;; )
 519
 520 ;; (unless (fboundp 'with-compilation-unit)
 521 ;; (defmacro with-compilation-unit (options &body body)
 522 ;;   "Do the body, but delay compiler warnings until the end."
 523 ;;   ;; That way, undefined function warnings that are really
 524 ;;   ;; just forward references will not be printed at all.
 525 ;;   ;; This is defined in Common Lisp the Language, 2nd ed.
 526 ;;   (declare (ignore options))
 527 ;;   `(,(read-time-case
 528 ;;        #+Lispm 'compiler:compiler-warnings-context-bind
 529 ;;        #+Lucid 'with-deferred-warnings
 530 ;;                'progn)
 531 ;;     .,body))
 532 ;; )
 533
 534 ;; ;;;; Reduce
 535
 536 ;; (when nil ;; Change this to T if you need REDUCE with :key keyword.
 537
 538 ;; (defun reduce* (fn seq from-end start end key init init-p)
 539 ;;   (funcall (if (listp seq) #'reduce-list #'reduce-vect)
 540 ;;            fn seq from-end (or start 0) end key init init-p))
 541
 542 ;; (defun reduce (function sequence &key from-end start end key
 543 ;;                (initial-value nil initial-value-p))
 544 ;;   (reduce* function sequence from-end start end
 545 ;;            key initial-value initial-value-p))
 546
 547 ;; (defun reduce-vect (fn seq from-end start end key init init-p)
 548 ;;   (if (null end) (setf end (length seq)))
 549 ;;   (assert (<= 0 start end (length seq)) (start end)
 550 ;;           "Illegal subsequence of ~a --- :start ~d :end ~d"
 551 ;;           seq start end)
 552 ;;   (case (- end start)
 553 ;;     (1 (if init-p
 554 ;;            (funcall fn init (funcall-if key (aref seq start)))
 555 ;;            (funcall-if key (aref seq start))))
 556 ;;     (0 (if init-p init (funcall fn)))
 557 ;;     (t (if (not from-end)
 558 ;;            (let ((result
 559 ;;                    (if init-p
 560 ;;                        (funcall
 561 ;;                          fn init
 562 ;;                          (funcall-if key (aref seq start)))
 563 ;;                        (funcall
 564 ;;                          fn
 565 ;;                          (funcall-if key (aref seq start))
 566 ;;                          (funcall-if key (aref seq (+ start 1)))))))
 567 ;;              (loop for i from (+ start (if init-p 1 2))
 568 ;;                    to (- end 1)
 569 ;;                    do (setf result
 570 ;;                             (funcall
 571 ;;                               fn result
 572 ;;                               (funcall-if key (aref seq i)))))
 573 ;;              result)
 574 ;;            (let ((result
 575 ;;                    (if init-p
 576 ;;                        (funcall
 577 ;;                          fn
 578 ;;                          (funcall-if key (aref seq (- end 1)))
 579 ;;                          init)
 580 ;;                        (funcall
 581 ;;                          fn
 582 ;;                          (funcall-if key (aref seq (- end 2)))
 583 ;;                          (funcall-if key (aref seq (- end 1)))))))
 584 ;;              (loop for i from (- end (if init-p 2 3)) downto start
 585 ;;                    do (setf result
 586 ;;                             (funcall
 587 ;;                               fn
 588 ;;                               (funcall-if key (aref seq i))
 589 ;;                               result)))
 590 ;;              result)))))
 591
 592 ;; (defun reduce-list (fn seq from-end start end key init init-p)
 593 ;;   (if (null end) (setf end (length seq)))
 594 ;;   (cond ((> start 0)
 595 ;;          (reduce-list fn (nthcdr start seq) from-end 0
 596 ;;                       (- end start) key init init-p))
 597 ;;         ((or (null seq) (eql start end))
 598 ;;          (if init-p init (funcall fn)))
 599 ;;         ((= (- end start) 1)
 600 ;;          (if init-p
 601 ;;              (funcall fn init (funcall-if key (first seq)))
 602 ;;              (funcall-if key (first seq))))
 603 ;;         (from-end
 604 ;;          (reduce-vect fn (coerce seq 'vector) t start end
 605 ;;                       key init init-p))
 606 ;;         ((null (rest seq))
 607 ;;          (if init-p
 608 ;;              (funcall fn init (funcall-if key (first seq)))
 609 ;;              (funcall-if key (first seq))))
 610 ;;         (t (let ((result
 611 ;;                    (if init-p
 612 ;;                        (funcall
 613 ;;                          fn init
 614 ;;                          (funcall-if key (pop seq)))
 615 ;;                        (funcall
 616 ;;                          fn
 617 ;;                          (funcall-if key (pop seq))
 618 ;;                          (funcall-if key (pop seq))))))
 619 ;;              (if end
 620 ;;                  (loop repeat (- end (if init-p 1 2)) while seq
 621 ;;                     do (setf result
 622 ;;                              (funcall
 623 ;;                                fn result
 624 ;;                                (funcall-if key (pop seq)))))
 625 ;;                  (loop while seq
 626 ;;                     do (setf result
 627 ;;                              (funcall
 628 ;;                                fn result
 629 ;;                                (funcall-if key (pop seq))))))
 630 ;;              result))))
 631 ;; )