emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Emacs-diffs] Changes to emacs/lisp/emacs-lisp/cl-macs.el [lexbind]


From: Miles Bader
Subject: [Emacs-diffs] Changes to emacs/lisp/emacs-lisp/cl-macs.el [lexbind]
Date: Wed, 08 Dec 2004 18:49:16 -0500

Index: emacs/lisp/emacs-lisp/cl-macs.el
diff -c emacs/lisp/emacs-lisp/cl-macs.el:1.34.4.4 
emacs/lisp/emacs-lisp/cl-macs.el:1.34.4.5
*** emacs/lisp/emacs-lisp/cl-macs.el:1.34.4.4   Tue May 11 02:33:56 2004
--- emacs/lisp/emacs-lisp/cl-macs.el    Wed Dec  8 23:31:40 2004
***************
*** 292,298 ****
          (laterarg nil) (exactarg nil) minarg)
        (or num (setq num 0))
        (if (listp (cadr restarg))
!         (setq restarg (gensym "--rest--"))
        (setq restarg (cadr restarg)))
        (push (list restarg expr) bind-lets)
        (if (eq (car args) '&whole)
--- 292,298 ----
          (laterarg nil) (exactarg nil) minarg)
        (or num (setq num 0))
        (if (listp (cadr restarg))
!         (setq restarg (make-symbol "--cl-rest--"))
        (setq restarg (cadr restarg)))
        (push (list restarg expr) bind-lets)
        (if (eq (car args) '&whole)
***************
*** 354,360 ****
                   (look (list 'memq (list 'quote karg) restarg)))
              (and def bind-enquote (setq def (list 'quote def)))
              (if (cddr arg)
!                 (let* ((temp (or (nth 2 arg) (gensym)))
                         (val (list 'car (list 'cdr temp))))
                    (cl-do-arglist temp look)
                    (cl-do-arglist varg
--- 354,360 ----
                   (look (list 'memq (list 'quote karg) restarg)))
              (and def bind-enquote (setq def (list 'quote def)))
              (if (cddr arg)
!                 (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--")))
                         (val (list 'car (list 'cdr temp))))
                    (cl-do-arglist temp look)
                    (cl-do-arglist varg
***************
*** 377,383 ****
        (setq keys (nreverse keys))
        (or (and (eq (car args) '&allow-other-keys) (pop args))
          (null keys) (= safety 0)
!         (let* ((var (gensym "--keys--"))
                 (allow '(:allow-other-keys))
                 (check (list
                         'while var
--- 377,383 ----
        (setq keys (nreverse keys))
        (or (and (eq (car args) '&allow-other-keys) (pop args))
          (null keys) (= safety 0)
!         (let* ((var (make-symbol "--cl-keys--"))
                 (allow '(:allow-other-keys))
                 (check (list
                         'while var
***************
*** 494,500 ****
  place of a KEYLIST of one atom.  A KEYLIST of t or `otherwise' is
  allowed only in the final clause, and matches if no other keys match.
  Key values are compared by `eql'."
!   (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym)))
         (head-list nil)
         (body (cons
                'cond
--- 494,500 ----
  place of a KEYLIST of one atom.  A KEYLIST of t or `otherwise' is
  allowed only in the final clause, and matches if no other keys match.
  Key values are compared by `eql'."
!   (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
         (head-list nil)
         (body (cons
                'cond
***************
*** 530,536 ****
  satisfies TYPE, the corresponding BODY is evaluated.  If no clause succeeds,
  typecase returns nil.  A TYPE of t or `otherwise' is allowed only in the
  final clause, and matches if no other keys match."
!   (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym)))
         (type-list nil)
         (body (cons
                'cond
--- 530,536 ----
  satisfies TYPE, the corresponding BODY is evaluated.  If no clause succeeds,
  typecase returns nil.  A TYPE of t or `otherwise' is allowed only in the
  final clause, and matches if no other keys match."
!   (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
         (type-list nil)
         (body (cons
                'cond
***************
*** 644,653 ****
        (setq args (append args '(cl-end-loop)))
        (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause))
        (if loop-finish-flag
!         (push (list (list loop-finish-flag t)) loop-bindings))
        (if loop-first-flag
!         (progn (push (list (list loop-first-flag t)) loop-bindings)
!                (push (list 'setq loop-first-flag nil) loop-steps)))
        (let* ((epilogue (nconc (nreverse loop-finally)
                              (list (or loop-result-explicit loop-result))))
             (ands (cl-loop-build-ands (nreverse loop-body)))
--- 644,653 ----
        (setq args (append args '(cl-end-loop)))
        (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause))
        (if loop-finish-flag
!         (push `((,loop-finish-flag t)) loop-bindings))
        (if loop-first-flag
!         (progn (push `((,loop-first-flag t)) loop-bindings)
!                (push `(setq ,loop-first-flag nil) loop-steps)))
        (let* ((epilogue (nconc (nreverse loop-finally)
                              (list (or loop-result-explicit loop-result))))
             (ands (cl-loop-build-ands (nreverse loop-body)))
***************
*** 658,673 ****
                              (list 'block '--cl-finish--
                                    (subst
                                     (if (eq (car ands) t) while-body
!                                      (cons (list 'or (car ands)
!                                                  '(return-from --cl-finish--
!                                                     nil))
                                             while-body))
                                     '--cl-map loop-map-form))
                            (list* 'while (car ands) while-body)))
                    (if loop-finish-flag
                        (if (equal epilogue '(nil)) (list loop-result-var)
!                         (list (list 'if loop-finish-flag
!                                     (cons 'progn epilogue) loop-result-var)))
                      epilogue))))
        (if loop-result-var (push (list loop-result-var) loop-bindings))
        (while loop-bindings
--- 658,673 ----
                              (list 'block '--cl-finish--
                                    (subst
                                     (if (eq (car ands) t) while-body
!                                      (cons `(or ,(car ands)
!                                                 (return-from --cl-finish--
!                                                   nil))
                                             while-body))
                                     '--cl-map loop-map-form))
                            (list* 'while (car ands) while-body)))
                    (if loop-finish-flag
                        (if (equal epilogue '(nil)) (list loop-result-var)
!                         `((if ,loop-finish-flag
!                               (progn ,@epilogue) ,loop-result-var)))
                      epilogue))))
        (if loop-result-var (push (list loop-result-var) loop-bindings))
        (while loop-bindings
***************
*** 682,688 ****
            (setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))
        (list* 'block loop-name body)))))
  
! (defun cl-parse-loop-clause ()   ; uses args, loop-*
    (let ((word (pop args))
        (hash-types '(hash-key hash-keys hash-value hash-values))
        (key-types '(key-code key-codes key-seq key-seqs
--- 682,688 ----
            (setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))
        (list* 'block loop-name body)))))
  
! (defun cl-parse-loop-clause ()                ; uses args, loop-*
    (let ((word (pop args))
        (hash-types '(hash-key hash-keys hash-value hash-values))
        (key-types '(key-code key-codes key-seq key-seqs
***************
*** 715,721 ****
        (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
            (ands nil))
        (while
!           (let ((var (or (pop args) (gensym))))
              (setq word (pop args))
              (if (eq word 'being) (setq word (pop args)))
              (if (memq word '(the each)) (setq word (pop args)))
--- 715,721 ----
        (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
            (ands nil))
        (while
!           (let ((var (or (pop args) (make-symbol "--cl-var--"))))
              (setq word (pop args))
              (if (eq word 'being) (setq word (pop args)))
              (if (memq word '(the each)) (setq word (pop args)))
***************
*** 738,763 ****
                                       '(to upto downto above below))
                                 (cl-pop2 args)))
                       (step (and (eq (car args) 'by) (cl-pop2 args)))
!                      (end-var (and (not (cl-const-expr-p end)) (gensym)))
                       (step-var (and (not (cl-const-expr-p step))
!                                     (gensym))))
                  (and step (numberp step) (<= step 0)
                       (error "Loop `by' value is not positive: %s" step))
                  (push (list var (or start 0)) loop-for-bindings)
                  (if end-var (push (list end-var end) loop-for-bindings))
                  (if step-var (push (list step-var step)
!                                       loop-for-bindings))
                  (if end
                      (push (list
!                               (if down (if excl '> '>=) (if excl '< '<=))
!                               var (or end-var end)) loop-body))
                  (push (list var (list (if down '- '+) var
!                                          (or step-var step 1)))
!                          loop-for-steps)))
  
               ((memq word '(in in-ref on))
                (let* ((on (eq word 'on))
!                      (temp (if (and on (symbolp var)) var (gensym))))
                  (push (list temp (pop args)) loop-for-bindings)
                  (push (list 'consp temp) loop-body)
                  (if (eq word 'in-ref)
--- 738,765 ----
                                       '(to upto downto above below))
                                 (cl-pop2 args)))
                       (step (and (eq (car args) 'by) (cl-pop2 args)))
!                      (end-var (and (not (cl-const-expr-p end))
!                                    (make-symbol "--cl-var--")))
                       (step-var (and (not (cl-const-expr-p step))
!                                     (make-symbol "--cl-var--"))))
                  (and step (numberp step) (<= step 0)
                       (error "Loop `by' value is not positive: %s" step))
                  (push (list var (or start 0)) loop-for-bindings)
                  (if end-var (push (list end-var end) loop-for-bindings))
                  (if step-var (push (list step-var step)
!                                    loop-for-bindings))
                  (if end
                      (push (list
!                            (if down (if excl '> '>=) (if excl '< '<=))
!                            var (or end-var end)) loop-body))
                  (push (list var (list (if down '- '+) var
!                                       (or step-var step 1)))
!                       loop-for-steps)))
  
               ((memq word '(in in-ref on))
                (let* ((on (eq word 'on))
!                      (temp (if (and on (symbolp var))
!                                var (make-symbol "--cl-var--"))))
                  (push (list temp (pop args)) loop-for-bindings)
                  (push (list 'consp temp) loop-body)
                  (if (eq word 'in-ref)
***************
*** 766,783 ****
                        (progn
                          (push (list var nil) loop-for-bindings)
                          (push (list var (if on temp (list 'car temp)))
!                                  loop-for-sets))))
                  (push (list temp
!                                (if (eq (car args) 'by)
!                                    (let ((step (cl-pop2 args)))
!                                      (if (and (memq (car-safe step)
!                                                     '(quote function
!                                                             function*))
!                                               (symbolp (nth 1 step)))
!                                          (list (nth 1 step) temp)
!                                        (list 'funcall step temp)))
!                                  (list 'cdr temp)))
!                          loop-for-steps)))
  
               ((eq word '=)
                (let* ((start (pop args))
--- 768,785 ----
                        (progn
                          (push (list var nil) loop-for-bindings)
                          (push (list var (if on temp (list 'car temp)))
!                               loop-for-sets))))
                  (push (list temp
!                             (if (eq (car args) 'by)
!                                 (let ((step (cl-pop2 args)))
!                                   (if (and (memq (car-safe step)
!                                                  '(quote function
!                                                          function*))
!                                            (symbolp (nth 1 step)))
!                                       (list (nth 1 step) temp)
!                                     (list 'funcall step temp)))
!                               (list 'cdr temp)))
!                       loop-for-steps)))
  
               ((eq word '=)
                (let* ((start (pop args))
***************
*** 785,852 ****
                  (push (list var nil) loop-for-bindings)
                  (if (or ands (eq (car args) 'and))
                      (progn
!                       (push (list var
!                                      (list 'if
!                                            (or loop-first-flag
!                                                (setq loop-first-flag
!                                                      (gensym)))
!                                            start var))
!                                loop-for-sets)
                        (push (list var then) loop-for-steps))
                    (push (list var
!                                  (if (eq start then) start
!                                    (list 'if
!                                          (or loop-first-flag
!                                              (setq loop-first-flag (gensym)))
!                                          start then)))
!                            loop-for-sets))))
  
               ((memq word '(across across-ref))
!               (let ((temp-vec (gensym)) (temp-idx (gensym)))
                  (push (list temp-vec (pop args)) loop-for-bindings)
                  (push (list temp-idx -1) loop-for-bindings)
                  (push (list '< (list 'setq temp-idx (list '1+ temp-idx))
!                                (list 'length temp-vec)) loop-body)
                  (if (eq word 'across-ref)
                      (push (list var (list 'aref temp-vec temp-idx))
!                              loop-symbol-macs)
                    (push (list var nil) loop-for-bindings)
                    (push (list var (list 'aref temp-vec temp-idx))
!                            loop-for-sets))))
  
               ((memq word '(element elements))
                (let ((ref (or (memq (car args) '(in-ref of-ref))
                               (and (not (memq (car args) '(in of)))
                                    (error "Expected `of'"))))
                      (seq (cl-pop2 args))
!                     (temp-seq (gensym))
                      (temp-idx (if (eq (car args) 'using)
                                    (if (and (= (length (cadr args)) 2)
                                             (eq (caadr args) 'index))
                                        (cadr (cl-pop2 args))
                                      (error "Bad `using' clause"))
!                                 (gensym))))
                  (push (list temp-seq seq) loop-for-bindings)
                  (push (list temp-idx 0) loop-for-bindings)
                  (if ref
!                     (let ((temp-len (gensym)))
                        (push (list temp-len (list 'length temp-seq))
!                                loop-for-bindings)
                        (push (list var (list 'elt temp-seq temp-idx))
!                                loop-symbol-macs)
                        (push (list '< temp-idx temp-len) loop-body))
                    (push (list var nil) loop-for-bindings)
                    (push (list 'and temp-seq
!                                  (list 'or (list 'consp temp-seq)
!                                        (list '< temp-idx
!                                              (list 'length temp-seq))))
!                            loop-body)
                    (push (list var (list 'if (list 'consp temp-seq)
!                                            (list 'pop temp-seq)
!                                            (list 'aref temp-seq temp-idx)))
!                            loop-for-sets))
                  (push (list temp-idx (list '1+ temp-idx))
!                          loop-for-steps)))
  
               ((memq word hash-types)
                (or (memq (car args) '(in of)) (error "Expected `of'"))
--- 787,854 ----
                  (push (list var nil) loop-for-bindings)
                  (if (or ands (eq (car args) 'and))
                      (progn
!                       (push `(,var
!                               (if ,(or loop-first-flag
!                                        (setq loop-first-flag
!                                              (make-symbol "--cl-var--")))
!                                   ,start ,var))
!                             loop-for-sets)
                        (push (list var then) loop-for-steps))
                    (push (list var
!                               (if (eq start then) start
!                                 `(if ,(or loop-first-flag
!                                           (setq loop-first-flag
!                                                 (make-symbol "--cl-var--")))
!                                      ,start ,then)))
!                         loop-for-sets))))
  
               ((memq word '(across across-ref))
!               (let ((temp-vec (make-symbol "--cl-vec--"))
!                     (temp-idx (make-symbol "--cl-idx--")))
                  (push (list temp-vec (pop args)) loop-for-bindings)
                  (push (list temp-idx -1) loop-for-bindings)
                  (push (list '< (list 'setq temp-idx (list '1+ temp-idx))
!                             (list 'length temp-vec)) loop-body)
                  (if (eq word 'across-ref)
                      (push (list var (list 'aref temp-vec temp-idx))
!                           loop-symbol-macs)
                    (push (list var nil) loop-for-bindings)
                    (push (list var (list 'aref temp-vec temp-idx))
!                         loop-for-sets))))
  
               ((memq word '(element elements))
                (let ((ref (or (memq (car args) '(in-ref of-ref))
                               (and (not (memq (car args) '(in of)))
                                    (error "Expected `of'"))))
                      (seq (cl-pop2 args))
!                     (temp-seq (make-symbol "--cl-seq--"))
                      (temp-idx (if (eq (car args) 'using)
                                    (if (and (= (length (cadr args)) 2)
                                             (eq (caadr args) 'index))
                                        (cadr (cl-pop2 args))
                                      (error "Bad `using' clause"))
!                                 (make-symbol "--cl-idx--"))))
                  (push (list temp-seq seq) loop-for-bindings)
                  (push (list temp-idx 0) loop-for-bindings)
                  (if ref
!                     (let ((temp-len (make-symbol "--cl-len--")))
                        (push (list temp-len (list 'length temp-seq))
!                             loop-for-bindings)
                        (push (list var (list 'elt temp-seq temp-idx))
!                             loop-symbol-macs)
                        (push (list '< temp-idx temp-len) loop-body))
                    (push (list var nil) loop-for-bindings)
                    (push (list 'and temp-seq
!                               (list 'or (list 'consp temp-seq)
!                                     (list '< temp-idx
!                                           (list 'length temp-seq))))
!                         loop-body)
                    (push (list var (list 'if (list 'consp temp-seq)
!                                         (list 'pop temp-seq)
!                                         (list 'aref temp-seq temp-idx)))
!                         loop-for-sets))
                  (push (list temp-idx (list '1+ temp-idx))
!                       loop-for-steps)))
  
               ((memq word hash-types)
                (or (memq (car args) '(in of)) (error "Expected `of'"))
***************
*** 857,877 ****
                                           (not (eq (caadr args) word)))
                                      (cadr (cl-pop2 args))
                                    (error "Bad `using' clause"))
!                               (gensym))))
                  (if (memq word '(hash-value hash-values))
                      (setq var (prog1 other (setq other var))))
                  (setq loop-map-form
!                       (list 'maphash (list 'function
!                                            (list* 'lambda (list var other)
!                                                   '--cl-map)) table))))
  
               ((memq word '(symbol present-symbol external-symbol
                             symbols present-symbols external-symbols))
                (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args))))
                  (setq loop-map-form
!                       (list 'mapatoms (list 'function
!                                             (list* 'lambda (list var)
!                                                    '--cl-map)) ob))))
  
               ((memq word '(overlay overlays extent extents))
                (let ((buf nil) (from nil) (to nil))
--- 859,875 ----
                                           (not (eq (caadr args) word)))
                                      (cadr (cl-pop2 args))
                                    (error "Bad `using' clause"))
!                               (make-symbol "--cl-var--"))))
                  (if (memq word '(hash-value hash-values))
                      (setq var (prog1 other (setq other var))))
                  (setq loop-map-form
!                       `(maphash (lambda (,var ,other) . --cl-map) ,table))))
  
               ((memq word '(symbol present-symbol external-symbol
                             symbols present-symbols external-symbols))
                (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args))))
                  (setq loop-map-form
!                       `(mapatoms (lambda (,var) . --cl-map) ,ob))))
  
               ((memq word '(overlay overlays extent extents))
                (let ((buf nil) (from nil) (to nil))
***************
*** 880,893 ****
                          ((eq (car args) 'to) (setq to (cl-pop2 args)))
                          (t (setq buf (cl-pop2 args)))))
                  (setq loop-map-form
!                       (list 'cl-map-extents
!                             (list 'function (list 'lambda (list var (gensym))
!                                                   '(progn . --cl-map) nil))
!                             buf from to))))
  
               ((memq word '(interval intervals))
                (let ((buf nil) (prop nil) (from nil) (to nil)
!                     (var1 (gensym)) (var2 (gensym)))
                  (while (memq (car args) '(in of property from to))
                    (cond ((eq (car args) 'from) (setq from (cl-pop2 args)))
                          ((eq (car args) 'to) (setq to (cl-pop2 args)))
--- 878,892 ----
                          ((eq (car args) 'to) (setq to (cl-pop2 args)))
                          (t (setq buf (cl-pop2 args)))))
                  (setq loop-map-form
!                       `(cl-map-extents
!                         (lambda (,var ,(make-symbol "--cl-var--"))
!                           (progn . --cl-map) nil)
!                         ,buf ,from ,to))))
  
               ((memq word '(interval intervals))
                (let ((buf nil) (prop nil) (from nil) (to nil)
!                     (var1 (make-symbol "--cl-var1--"))
!                     (var2 (make-symbol "--cl-var2--")))
                  (while (memq (car args) '(in of property from to))
                    (cond ((eq (car args) 'from) (setq from (cl-pop2 args)))
                          ((eq (car args) 'to) (setq to (cl-pop2 args)))
***************
*** 898,907 ****
                      (setq var1 (car var) var2 (cdr var))
                    (push (list var (list 'cons var1 var2)) loop-for-sets))
                  (setq loop-map-form
!                       (list 'cl-map-intervals
!                             (list 'function (list 'lambda (list var1 var2)
!                                                   '(progn . --cl-map)))
!                             buf prop from to))))
  
               ((memq word key-types)
                (or (memq (car args) '(in of)) (error "Expected `of'"))
--- 897,905 ----
                      (setq var1 (car var) var2 (cdr var))
                    (push (list var (list 'cons var1 var2)) loop-for-sets))
                  (setq loop-map-form
!                       `(cl-map-intervals
!                         (lambda (,var1 ,var2) . --cl-map)
!                         ,buf ,prop ,from ,to))))
  
               ((memq word key-types)
                (or (memq (car args) '(in of)) (error "Expected `of'"))
***************
*** 912,948 ****
                                          (not (eq (caadr args) word)))
                                     (cadr (cl-pop2 args))
                                   (error "Bad `using' clause"))
!                              (gensym))))
                  (if (memq word '(key-binding key-bindings))
                      (setq var (prog1 other (setq other var))))
                  (setq loop-map-form
!                       (list (if (memq word '(key-seq key-seqs))
!                                 'cl-map-keymap-recursively 'map-keymap)
!                             (list 'function (list* 'lambda (list var other)
!                                                    '--cl-map)) map))))
  
               ((memq word '(frame frames screen screens))
!               (let ((temp (gensym)))
                  (push (list var  '(selected-frame))
!                          loop-for-bindings)
                  (push (list temp nil) loop-for-bindings)
                  (push (list 'prog1 (list 'not (list 'eq var temp))
!                                (list 'or temp (list 'setq temp var)))
!                          loop-body)
                  (push (list var (list 'next-frame var))
!                          loop-for-steps)))
  
               ((memq word '(window windows))
                (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
!                     (temp (gensym)))
                  (push (list var (if scr
!                                        (list 'frame-selected-window scr)
!                                      '(selected-window)))
!                          loop-for-bindings)
                  (push (list temp nil) loop-for-bindings)
                  (push (list 'prog1 (list 'not (list 'eq var temp))
!                                (list 'or temp (list 'setq temp var)))
!                          loop-body)
                  (push (list var (list 'next-window var)) loop-for-steps)))
  
               (t
--- 910,945 ----
                                          (not (eq (caadr args) word)))
                                     (cadr (cl-pop2 args))
                                   (error "Bad `using' clause"))
!                              (make-symbol "--cl-var--"))))
                  (if (memq word '(key-binding key-bindings))
                      (setq var (prog1 other (setq other var))))
                  (setq loop-map-form
!                       `(,(if (memq word '(key-seq key-seqs))
!                              'cl-map-keymap-recursively 'map-keymap)
!                         (lambda (,var ,other) . --cl-map) ,map))))
  
               ((memq word '(frame frames screen screens))
!               (let ((temp (make-symbol "--cl-var--")))
                  (push (list var  '(selected-frame))
!                       loop-for-bindings)
                  (push (list temp nil) loop-for-bindings)
                  (push (list 'prog1 (list 'not (list 'eq var temp))
!                             (list 'or temp (list 'setq temp var)))
!                       loop-body)
                  (push (list var (list 'next-frame var))
!                       loop-for-steps)))
  
               ((memq word '(window windows))
                (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
!                     (temp (make-symbol "--cl-var--")))
                  (push (list var (if scr
!                                     (list 'frame-selected-window scr)
!                                   '(selected-window)))
!                       loop-for-bindings)
                  (push (list temp nil) loop-for-bindings)
                  (push (list 'prog1 (list 'not (list 'eq var temp))
!                             (list 'or temp (list 'setq temp var)))
!                       loop-body)
                  (push (list var (list 'next-window var)) loop-for-steps)))
  
               (t
***************
*** 960,974 ****
                                     loop-bindings)))
        (if loop-for-sets
            (push (list 'progn
!                          (cl-loop-let (nreverse loop-for-sets) 'setq ands)
!                          t) loop-body))
        (if loop-for-steps
            (push (cons (if ands 'psetq 'setq)
!                          (apply 'append (nreverse loop-for-steps)))
!                    loop-steps))))
  
       ((eq word 'repeat)
!       (let ((temp (gensym)))
        (push (list (list temp (pop args))) loop-bindings)
        (push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))
  
--- 957,971 ----
                                     loop-bindings)))
        (if loop-for-sets
            (push (list 'progn
!                       (cl-loop-let (nreverse loop-for-sets) 'setq ands)
!                       t) loop-body))
        (if loop-for-steps
            (push (cons (if ands 'psetq 'setq)
!                       (apply 'append (nreverse loop-for-steps)))
!                 loop-steps))))
  
       ((eq word 'repeat)
!       (let ((temp (make-symbol "--cl-var--")))
        (push (list (list temp (pop args))) loop-bindings)
        (push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))
  
***************
*** 978,1000 ****
        (if (eq var loop-accum-var)
            (push (list 'progn (list 'push what var) t) loop-body)
          (push (list 'progn
!                        (list 'setq var (list 'nconc var (list 'list what)))
!                        t) loop-body))))
  
       ((memq word '(nconc nconcing append appending))
        (let ((what (pop args))
            (var (cl-loop-handle-accum nil 'nreverse)))
        (push (list 'progn
!                      (list 'setq var
!                            (if (eq var loop-accum-var)
!                                (list 'nconc
!                                      (list (if (memq word '(nconc nconcing))
!                                                'nreverse 'reverse)
!                                            what)
!                                      var)
!                              (list (if (memq word '(nconc nconcing))
!                                        'nconc 'append)
!                                    var what))) t) loop-body)))
  
       ((memq word '(concat concating))
        (let ((what (pop args))
--- 975,997 ----
        (if (eq var loop-accum-var)
            (push (list 'progn (list 'push what var) t) loop-body)
          (push (list 'progn
!                     (list 'setq var (list 'nconc var (list 'list what)))
!                     t) loop-body))))
  
       ((memq word '(nconc nconcing append appending))
        (let ((what (pop args))
            (var (cl-loop-handle-accum nil 'nreverse)))
        (push (list 'progn
!                   (list 'setq var
!                         (if (eq var loop-accum-var)
!                             (list 'nconc
!                                   (list (if (memq word '(nconc nconcing))
!                                             'nreverse 'reverse)
!                                         what)
!                                   var)
!                           (list (if (memq word '(nconc nconcing))
!                                     'nconc 'append)
!                                 var what))) t) loop-body)))
  
       ((memq word '(concat concating))
        (let ((what (pop args))
***************
*** 1018,1036 ****
  
       ((memq word '(minimize minimizing maximize maximizing))
        (let* ((what (pop args))
!            (temp (if (cl-simple-expr-p what) what (gensym)))
             (var (cl-loop-handle-accum nil))
             (func (intern (substring (symbol-name word) 0 3)))
             (set (list 'setq var (list 'if var (list func var temp) temp))))
        (push (list 'progn (if (eq temp what) set
!                               (list 'let (list (list temp what)) set))
!                      t) loop-body)))
  
       ((eq word 'with)
        (let ((bindings nil))
        (while (progn (push (list (pop args)
!                                    (and (eq (car args) '=) (cl-pop2 args)))
!                              bindings)
                      (eq (car args) 'and))
          (pop args))
        (push (nreverse bindings) loop-bindings)))
--- 1015,1033 ----
  
       ((memq word '(minimize minimizing maximize maximizing))
        (let* ((what (pop args))
!            (temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--")))
             (var (cl-loop-handle-accum nil))
             (func (intern (substring (symbol-name word) 0 3)))
             (set (list 'setq var (list 'if var (list func var temp) temp))))
        (push (list 'progn (if (eq temp what) set
!                            (list 'let (list (list temp what)) set))
!                   t) loop-body)))
  
       ((eq word 'with)
        (let ((bindings nil))
        (while (progn (push (list (pop args)
!                                 (and (eq (car args) '=) (cl-pop2 args)))
!                           bindings)
                      (eq (car args) 'and))
          (pop args))
        (push (nreverse bindings) loop-bindings)))
***************
*** 1042,1063 ****
        (push (list 'not (pop args)) loop-body))
  
       ((eq word 'always)
!       (or loop-finish-flag (setq loop-finish-flag (gensym)))
        (push (list 'setq loop-finish-flag (pop args)) loop-body)
        (setq loop-result t))
  
       ((eq word 'never)
!       (or loop-finish-flag (setq loop-finish-flag (gensym)))
        (push (list 'setq loop-finish-flag (list 'not (pop args)))
!              loop-body)
        (setq loop-result t))
  
       ((eq word 'thereis)
!       (or loop-finish-flag (setq loop-finish-flag (gensym)))
!       (or loop-result-var (setq loop-result-var (gensym)))
        (push (list 'setq loop-finish-flag
!                    (list 'not (list 'setq loop-result-var (pop args))))
!              loop-body))
  
       ((memq word '(if when unless))
        (let* ((cond (pop args))
--- 1039,1060 ----
        (push (list 'not (pop args)) loop-body))
  
       ((eq word 'always)
!       (or loop-finish-flag (setq loop-finish-flag (make-symbol 
"--cl-flag--")))
        (push (list 'setq loop-finish-flag (pop args)) loop-body)
        (setq loop-result t))
  
       ((eq word 'never)
!       (or loop-finish-flag (setq loop-finish-flag (make-symbol 
"--cl-flag--")))
        (push (list 'setq loop-finish-flag (list 'not (pop args)))
!           loop-body)
        (setq loop-result t))
  
       ((eq word 'thereis)
!       (or loop-finish-flag (setq loop-finish-flag (make-symbol 
"--cl-flag--")))
!       (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
        (push (list 'setq loop-finish-flag
!                 (list 'not (list 'setq loop-result-var (pop args))))
!           loop-body))
  
       ((memq word '(if when unless))
        (let* ((cond (pop args))
***************
*** 1074,1080 ****
        (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
                          (if simple (nth 1 else) (list (nth 2 else))))))
          (if (cl-expr-contains form 'it)
!             (let ((temp (gensym)))
                (push (list temp) loop-bindings)
                (setq form (list* 'if (list 'setq temp cond)
                                  (subst temp 'it form))))
--- 1071,1077 ----
        (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
                          (if simple (nth 1 else) (list (nth 2 else))))))
          (if (cl-expr-contains form 'it)
!             (let ((temp (make-symbol "--cl-var--")))
                (push (list temp) loop-bindings)
                (setq form (list* 'if (list 'setq temp cond)
                                  (subst temp 'it form))))
***************
*** 1088,1097 ****
        (push (cons 'progn (nreverse (cons t body))) loop-body)))
  
       ((eq word 'return)
!       (or loop-finish-flag (setq loop-finish-flag (gensym)))
!       (or loop-result-var (setq loop-result-var (gensym)))
        (push (list 'setq loop-result-var (pop args)
!                    loop-finish-flag nil) loop-body))
  
       (t
        (let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
--- 1085,1094 ----
        (push (cons 'progn (nreverse (cons t body))) loop-body)))
  
       ((eq word 'return)
!       (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--")))
!       (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
        (push (list 'setq loop-result-var (pop args)
!                 loop-finish-flag nil) loop-body))
  
       (t
        (let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
***************
*** 1109,1115 ****
           (setq par nil p specs)
           (while p
             (or (cl-const-expr-p (cadar p))
!                (let ((temp (gensym)))
                   (push (list temp (cadar p)) temps)
                   (setcar (cdar p) temp)))
             (setq p (cdr p)))))
--- 1106,1112 ----
           (setq par nil p specs)
           (while p
             (or (cl-const-expr-p (cadar p))
!                (let ((temp (make-symbol "--cl-var--")))
                   (push (list temp (cadar p)) temps)
                   (setcar (cdar p) temp)))
             (setq p (cdr p)))))
***************
*** 1119,1126 ****
                 (expr (cadr (pop specs)))
                 (temp (cdr (or (assq spec loop-destr-temps)
                                (car (push (cons spec (or (last spec 0)
!                                                            (gensym)))
!                                             loop-destr-temps))))))
            (push (list temp expr) new)
            (while (consp spec)
              (push (list (pop spec)
--- 1116,1123 ----
                 (expr (cadr (pop specs)))
                 (temp (cdr (or (assq spec loop-destr-temps)
                                (car (push (cons spec (or (last spec 0)
!                                                         (make-symbol 
"--cl-var--")))
!                                          loop-destr-temps))))))
            (push (list temp expr) new)
            (while (consp spec)
              (push (list (pop spec)
***************
*** 1143,1149 ****
        var)
      (or loop-accum-var
        (progn
!         (push (list (list (setq loop-accum-var (gensym)) def))
                   loop-bindings)
          (setq loop-result (if func (list func loop-accum-var)
                              loop-accum-var))
--- 1140,1146 ----
        var)
      (or loop-accum-var
        (progn
!         (push (list (list (setq loop-accum-var (make-symbol "--cl-var--")) 
def))
                   loop-bindings)
          (setq loop-result (if func (list func loop-accum-var)
                              loop-accum-var))
***************
*** 1214,1220 ****
  Then evaluate RESULT to get return value, default nil.
  
  \(fn (VAR LIST [RESULT]) BODY...)"
!   (let ((temp (gensym "--dolist-temp--")))
      (list 'block nil
          (list* 'let (list (list temp (nth 1 spec)) (car spec))
                 (list* 'while temp (list 'setq (car spec) (list 'car temp))
--- 1211,1217 ----
  Then evaluate RESULT to get return value, default nil.
  
  \(fn (VAR LIST [RESULT]) BODY...)"
!   (let ((temp (make-symbol "--cl-dolist-temp--")))
      (list 'block nil
          (list* 'let (list (list temp (nth 1 spec)) (car spec))
                 (list* 'while temp (list 'setq (car spec) (list 'car temp))
***************
*** 1231,1237 ****
  nil.
  
  \(fn (VAR COUNT [RESULT]) BODY...)"
!   (let ((temp (gensym "--dotimes-temp--")))
      (list 'block nil
          (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0))
                 (list* 'while (list '< (car spec) temp)
--- 1228,1234 ----
  nil.
  
  \(fn (VAR COUNT [RESULT]) BODY...)"
!   (let ((temp (make-symbol "--cl-dotimes-temp--")))
      (list 'block nil
          (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0))
                 (list* 'while (list '< (car spec) temp)
***************
*** 1317,1323 ****
  \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
    (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
      (while bindings
!       (let ((var (gensym)))
        (push var vars)
        (push (list 'function* (cons 'lambda (cdar bindings))) sets)
        (push var sets)
--- 1314,1320 ----
  \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
    (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
      (while bindings
!       (let ((var (make-symbol "--cl-var--")))
        (push var vars)
        (push (list 'function* (cons 'lambda (cdar bindings))) sets)
        (push var sets)
***************
*** 1370,1377 ****
         (vars (mapcar (function
                        (lambda (x)
                          (or (consp x) (setq x (list x)))
!                         (push (gensym (format "--%s--" (car x)))
!                                  cl-closure-vars)
                          (set (car cl-closure-vars) [bad-lexical-ref])
                          (list (car x) (cadr x) (car cl-closure-vars))))
                       bindings))
--- 1367,1374 ----
         (vars (mapcar (function
                        (lambda (x)
                          (or (consp x) (setq x (list x)))
!                         (push (make-symbol (format "--cl-%s--" (car x)))
!                               cl-closure-vars)
                          (set (car cl-closure-vars) [bad-lexical-ref])
                          (list (car x) (cadr x) (car cl-closure-vars))))
                       bindings))
***************
*** 1432,1438 ****
  a synonym for (list A B C).
  
  \(fn (SYM SYM...) FORM BODY)"
!   (let ((temp (gensym)) (n -1))
      (list* 'let* (cons (list temp form)
                       (mapcar (function
                                (lambda (v)
--- 1429,1435 ----
  a synonym for (list A B C).
  
  \(fn (SYM SYM...) FORM BODY)"
!   (let ((temp (make-symbol "--cl-var--")) (n -1))
      (list* 'let* (cons (list temp form)
                       (mapcar (function
                                (lambda (v)
***************
*** 1451,1457 ****
    (cond ((null vars) (list 'progn form nil))
        ((null (cdr vars)) (list 'setq (car vars) (list 'car form)))
        (t
!        (let* ((temp (gensym)) (n 0))
           (list 'let (list (list temp form))
                 (list 'prog1 (list 'setq (pop vars) (list 'car temp))
                       (cons 'setq (apply 'nconc
--- 1448,1454 ----
    (cond ((null vars) (list 'progn form nil))
        ((null (cdr vars)) (list 'setq (car vars) (list 'car form)))
        (t
!        (let* ((temp (make-symbol "--cl-var--")) (n 0))
           (list 'let (list (list temp form))
                 (list 'prog1 (list 'setq (pop vars) (list 'car temp))
                       (cons 'setq (apply 'nconc
***************
*** 1590,1633 ****
          (setq largsr largs tempsr temps))
        (let ((p1 largs) (p2 temps))
          (while p1
!           (setq lets1 (cons (list (car p2)
!                                   (list 'gensym (format "--%s--" (car p1))))
                              lets1)
                  lets2 (cons (list (car p1) (car p2)) lets2)
                  p1 (cdr p1) p2 (cdr p2))))
        (if restarg (setq lets2 (cons (list restarg rest-temps) lets2)))
!       (append (list 'define-setf-method func arg1)
!               (and docstr (list docstr))
!               (list
!                (list 'let*
!                      (nreverse
!                       (cons (list store-temp
!                                   (list 'gensym (format "--%s--" store-var)))
!                             (if restarg
!                                 (append
!                                  (list
!                                   (list rest-temps
!                                         (list 'mapcar '(quote gensym)
!                                               restarg)))
!                                  lets1)
!                               lets1)))
!                      (list 'list  ; 'values
!                            (cons (if restarg 'list* 'list) tempsr)
!                            (cons (if restarg 'list* 'list) largsr)
!                            (list 'list store-temp)
!                            (cons 'let*
!                                  (cons (nreverse
!                                         (cons (list store-var store-temp)
!                                               lets2))
!                                        args))
!                            (cons (if restarg 'list* 'list)
!                                  (cons (list 'quote func) tempsr)))))))
!     (list 'defsetf func '(&rest args) '(store)
!         (let ((call (list 'cons (list 'quote arg1)
!                           '(append args (list store)))))
!           (if (car args)
!               (list 'list '(quote progn) call 'store)
!             call)))))
  
  ;;; Some standard place types from Common Lisp.
  (defsetf aref aset)
--- 1587,1627 ----
          (setq largsr largs tempsr temps))
        (let ((p1 largs) (p2 temps))
          (while p1
!           (setq lets1 (cons `(,(car p2)
!                               (make-symbol ,(format "--cl-%s--" (car p1))))
                              lets1)
                  lets2 (cons (list (car p1) (car p2)) lets2)
                  p1 (cdr p1) p2 (cdr p2))))
        (if restarg (setq lets2 (cons (list restarg rest-temps) lets2)))
!       `(define-setf-method ,func ,arg1
!          ,@(and docstr (list docstr))
!          (let*
!              ,(nreverse
!                (cons `(,store-temp
!                        (make-symbol ,(format "--cl-%s--" store-var)))
!                      (if restarg
!                          `((,rest-temps
!                             (mapcar (lambda (_) (make-symbol "--cl-var--"))
!                                     ,restarg))
!                            ,@lets1)
!                        lets1)))
!            (list                      ; 'values
!             (,(if restarg 'list* 'list) ,@tempsr)
!             (,(if restarg 'list* 'list) ,@largsr)
!             (list ,store-temp)
!             (let*
!                 ,(nreverse
!                   (cons (list store-var store-temp)
!                         lets2))
!               ,@args)
!             (,(if restarg 'list* 'list)
!              ,@(cons (list 'quote func) tempsr))))))
!     `(defsetf ,func (&rest args) (store)
!        ,(let ((call `(cons ',arg1
!                          (append args (list store)))))
!         (if (car args)
!             `(list 'progn ,call store)
!           call)))))
  
  ;;; Some standard place types from Common Lisp.
  (defsetf aref aset)
***************
*** 1781,1788 ****
  
  (define-setf-method nthcdr (n place)
    (let ((method (get-setf-method place cl-macro-environment))
!       (n-temp (gensym "--nthcdr-n--"))
!       (store-temp (gensym "--nthcdr-store--")))
      (list (cons n-temp (car method))
          (cons n (nth 1 method))
          (list store-temp)
--- 1775,1782 ----
  
  (define-setf-method nthcdr (n place)
    (let ((method (get-setf-method place cl-macro-environment))
!       (n-temp (make-symbol "--cl-nthcdr-n--"))
!       (store-temp (make-symbol "--cl-nthcdr-store--")))
      (list (cons n-temp (car method))
          (cons n (nth 1 method))
          (list store-temp)
***************
*** 1794,1802 ****
  
  (define-setf-method getf (place tag &optional def)
    (let ((method (get-setf-method place cl-macro-environment))
!       (tag-temp (gensym "--getf-tag--"))
!       (def-temp (gensym "--getf-def--"))
!       (store-temp (gensym "--getf-store--")))
      (list (append (car method) (list tag-temp def-temp))
          (append (nth 1 method) (list tag def))
          (list store-temp)
--- 1788,1796 ----
  
  (define-setf-method getf (place tag &optional def)
    (let ((method (get-setf-method place cl-macro-environment))
!       (tag-temp (make-symbol "--cl-getf-tag--"))
!       (def-temp (make-symbol "--cl-getf-def--"))
!       (store-temp (make-symbol "--cl-getf-store--")))
      (list (append (car method) (list tag-temp def-temp))
          (append (nth 1 method) (list tag def))
          (list store-temp)
***************
*** 1808,1816 ****
  
  (define-setf-method substring (place from &optional to)
    (let ((method (get-setf-method place cl-macro-environment))
!       (from-temp (gensym "--substring-from--"))
!       (to-temp (gensym "--substring-to--"))
!       (store-temp (gensym "--substring-store--")))
      (list (append (car method) (list from-temp to-temp))
          (append (nth 1 method) (list from to))
          (list store-temp)
--- 1802,1810 ----
  
  (define-setf-method substring (place from &optional to)
    (let ((method (get-setf-method place cl-macro-environment))
!       (from-temp (make-symbol "--cl-substring-from--"))
!       (to-temp (make-symbol "--cl-substring-to--"))
!       (store-temp (make-symbol "--cl-substring-store--")))
      (list (append (car method) (list from-temp to-temp))
          (append (nth 1 method) (list from to))
          (list store-temp)
***************
*** 1826,1832 ****
  PLACE may be any Lisp form which can appear as the PLACE argument to
  a macro like `setf' or `incf'."
    (if (symbolp place)
!       (let ((temp (gensym "--setf--")))
        (list nil nil (list temp) (list 'setq place temp) place))
      (or (and (symbolp (car place))
             (let* ((func (car place))
--- 1820,1826 ----
  PLACE may be any Lisp form which can appear as the PLACE argument to
  a macro like `setf' or `incf'."
    (if (symbolp place)
!       (let ((temp (make-symbol "--cl-setf--")))
        (list nil nil (list temp) (list 'setq place temp) place))
      (or (and (symbolp (car place))
             (let* ((func (car place))
***************
*** 1933,1939 ****
    (if (cl-simple-expr-p place)
        (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place)))
      (let* ((method (cl-setf-do-modify place t))
!          (temp (gensym "--pop--")))
        (list 'let*
            (append (car method)
                    (list (list temp (nth 2 method))))
--- 1927,1933 ----
    (if (cl-simple-expr-p place)
        (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place)))
      (let* ((method (cl-setf-do-modify place t))
!          (temp (make-symbol "--cl-pop--")))
        (list 'let*
            (append (car method)
                    (list (list temp (nth 2 method))))
***************
*** 1946,1954 ****
  PLACE may be a symbol, or any generalized variable allowed by `setf'.
  The form returns true if TAG was found and removed, nil otherwise."
    (let* ((method (cl-setf-do-modify place t))
!        (tag-temp (and (not (cl-const-expr-p tag)) (gensym "--remf-tag--")))
         (val-temp (and (not (cl-simple-expr-p place))
!                       (gensym "--remf-place--")))
         (ttag (or tag-temp tag))
         (tval (or val-temp (nth 2 method))))
      (list 'let*
--- 1940,1948 ----
  PLACE may be a symbol, or any generalized variable allowed by `setf'.
  The form returns true if TAG was found and removed, nil otherwise."
    (let* ((method (cl-setf-do-modify place t))
!        (tag-temp (and (not (cl-const-expr-p tag)) (make-symbol 
"--cl-remf-tag--")))
         (val-temp (and (not (cl-simple-expr-p place))
!                       (make-symbol "--cl-remf-place--")))
         (ttag (or tag-temp tag))
         (tval (or val-temp (nth 2 method))))
      (list 'let*
***************
*** 1990,1996 ****
               (setq sets (nconc sets (list (pop args) (car args)))))
             (nconc (list 'psetf) sets (list (car args) first))))
      (let* ((places (reverse args))
!          (temp (gensym "--rotatef--"))
           (form temp))
        (while (cdr places)
        (let ((method (cl-setf-do-modify (pop places) 'unsafe)))
--- 1984,1990 ----
               (setq sets (nconc sets (list (pop args) (car args)))))
             (nconc (list 'psetf) sets (list (car args) first))))
      (let* ((places (reverse args))
!          (temp (make-symbol "--cl-rotatef--"))
           (form temp))
        (while (cdr places)
        (let ((method (cl-setf-do-modify (pop places) 'unsafe)))
***************
*** 2022,2032 ****
                        (caar rev)))
               (value (cadar rev))
               (method (cl-setf-do-modify place 'no-opt))
!              (save (gensym "--letf-save--"))
               (bound (and (memq (car place) '(symbol-value symbol-function))
!                          (gensym "--letf-bound--")))
               (temp (and (not (cl-const-expr-p value)) (cdr bindings)
!                         (gensym "--letf-val--"))))
          (setq lets (nconc (car method)
                            (if bound
                                (list (list bound
--- 2016,2026 ----
                        (caar rev)))
               (value (cadar rev))
               (method (cl-setf-do-modify place 'no-opt))
!              (save (make-symbol "--cl-letf-save--"))
               (bound (and (memq (car place) '(symbol-value symbol-function))
!                          (make-symbol "--cl-letf-bound--")))
               (temp (and (not (cl-const-expr-p value)) (cdr bindings)
!                         (make-symbol "--cl-letf-val--"))))
          (setq lets (nconc (car method)
                            (if bound
                                (list (list bound
***************
*** 2097,2103 ****
    (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func))
        (list 'setf place (list* func arg1 place args))
      (let* ((method (cl-setf-do-modify place (cons 'list args)))
!          (temp (and (not (cl-const-expr-p arg1)) (gensym "--arg1--")))
           (rargs (list* (or temp arg1) (nth 2 method) args)))
        (list 'let* (append (and temp (list (list temp arg1))) (car method))
            (cl-setf-do-store (nth 1 method)
--- 2091,2097 ----
    (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func))
        (list 'setf place (list* func arg1 place args))
      (let* ((method (cl-setf-do-modify place (cons 'list args)))
!          (temp (and (not (cl-const-expr-p arg1)) (make-symbol "--cl-arg1--")))
           (rargs (list* (or temp arg1) (nth 2 method) args)))
        (list 'let* (append (and temp (list (list temp arg1))) (car method))
            (cl-setf-do-store (nth 1 method)
***************
*** 2110,2116 ****
  If NAME is called, it combines its PLACE argument with the other arguments
  from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)"
    (if (memq '&key arglist) (error "&key not allowed in define-modify-macro"))
!   (let ((place (gensym "--place--")))
      (list 'defmacro* name (cons place arglist) doc
          (list* (if (memq '&rest arglist) 'list* 'list)
                 '(quote callf) (list 'quote func) place
--- 2104,2110 ----
  If NAME is called, it combines its PLACE argument with the other arguments
  from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)"
    (if (memq '&key arglist) (error "&key not allowed in define-modify-macro"))
!   (let ((place (make-symbol "--cl-place--")))
      (list 'defmacro* name (cons place arglist) doc
          (list* (if (memq '&rest arglist) 'list* 'list)
                 '(quote callf) (list 'quote func) place
***************
*** 2334,2340 ****
      (cons 'progn (nreverse (cons (list 'quote name) forms)))))
  
  (defun cl-struct-setf-expander (x name accessor pred-form pos)
!   (let* ((temp (gensym "--x--")) (store (gensym "--store--")))
      (list (list temp) (list x) (list store)
          (append '(progn)
                  (and pred-form
--- 2328,2334 ----
      (cons 'progn (nreverse (cons (list 'quote name) forms)))))
  
  (defun cl-struct-setf-expander (x name accessor pred-form pos)
!   (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--")))
      (list (list temp) (list x) (list store)
          (append '(progn)
                  (and pred-form
***************
*** 2410,2416 ****
  STRING is an optional description of the desired type."
    (and (or (not (cl-compiling-file))
           (< cl-optimize-speed 3) (= cl-optimize-safety 3))
!        (let* ((temp (if (cl-simple-expr-p form 3) form (gensym)))
              (body (list 'or (cl-make-type-test temp type)
                          (list 'signal '(quote wrong-type-argument)
                                (list 'list (or string (list 'quote type))
--- 2404,2411 ----
  STRING is an optional description of the desired type."
    (and (or (not (cl-compiling-file))
           (< cl-optimize-speed 3) (= cl-optimize-safety 3))
!        (let* ((temp (if (cl-simple-expr-p form 3)
!                       form (make-symbol "--cl-var--")))
              (body (list 'or (cl-make-type-test temp type)
                          (list 'signal '(quote wrong-type-argument)
                                (list 'list (or string (list 'quote type))
***************
*** 2607,2654 ****
        (let ((res (cl-make-type-test val (cl-const-expr-val type))))
        (if (or (memq (cl-expr-contains res val) '(nil 1))
                (cl-simple-expr-p val)) res
!         (let ((temp (gensym)))
            (list 'let (list (list temp val)) (subst temp val res)))))
      form))
  
  
! (mapcar (function
!        (lambda (y)
!          (put (car y) 'side-effect-free t)
!          (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro)
!          (put (car y) 'cl-compiler-macro
!               (list 'lambda '(w x)
!                     (if (symbolp (cadr y))
!                         (list 'list (list 'quote (cadr y))
!                               (list 'list (list 'quote (caddr y)) 'x))
!                       (cons 'list (cdr y)))))))
!       '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x)
!         (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x)
!         (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x)
!         (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0)
!         (caaar car caar) (caadr car cadr) (cadar car cdar)
!         (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr)
!         (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar)
!         (caaadr car caadr) (caadar car cadar) (caaddr car caddr)
!         (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar)
!         (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr)
!         (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar)
!         (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) ))
  
  ;;; Things that are inline.
  (proclaim '(inline floatp-safe acons map concatenate notany notevery
                   cl-set-elt revappend nreconc gethash))
  
  ;;; Things that are side-effect-free.
! (mapcar (function (lambda (x) (put x 'side-effect-free t)))
!       '(oddp evenp signum last butlast ldiff pairlis gcd lcm
!         isqrt floor* ceiling* truncate* round* mod* rem* subseq
!         list-length get* getf))
  
  ;;; Things that are side-effect-and-error-free.
! (mapcar (function (lambda (x) (put x 'side-effect-free 'error-free)))
!       '(eql floatp-safe list* subst acons equalp random-state-p
!         copy-tree sublis))
  
  
  (run-hooks 'cl-macs-load-hook)
--- 2602,2648 ----
        (let ((res (cl-make-type-test val (cl-const-expr-val type))))
        (if (or (memq (cl-expr-contains res val) '(nil 1))
                (cl-simple-expr-p val)) res
!         (let ((temp (make-symbol "--cl-var--")))
            (list 'let (list (list temp val)) (subst temp val res)))))
      form))
  
  
! (mapc (lambda (y)
!       (put (car y) 'side-effect-free t)
!       (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro)
!       (put (car y) 'cl-compiler-macro
!            `(lambda (w x)
!               ,(if (symbolp (cadr y))
!                    `(list ',(cadr y)
!                           (list ',(caddr y) x))
!                  (cons 'list (cdr y))))))
!       '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x)
!       (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x)
!       (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x)
!       (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0)
!       (caaar car caar) (caadr car cadr) (cadar car cdar)
!       (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr)
!       (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar)
!       (caaadr car caadr) (caadar car cadar) (caaddr car caddr)
!       (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar)
!       (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr)
!       (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar)
!       (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) ))
  
  ;;; Things that are inline.
  (proclaim '(inline floatp-safe acons map concatenate notany notevery
                   cl-set-elt revappend nreconc gethash))
  
  ;;; Things that are side-effect-free.
! (mapc (lambda (x) (put x 'side-effect-free t))
!       '(oddp evenp signum last butlast ldiff pairlis gcd lcm
!       isqrt floor* ceiling* truncate* round* mod* rem* subseq
!       list-length get* getf))
  
  ;;; Things that are side-effect-and-error-free.
! (mapc (lambda (x) (put x 'side-effect-free 'error-free))
!       '(eql floatp-safe list* subst acons equalp random-state-p
!       copy-tree sublis))
  
  
  (run-hooks 'cl-macs-load-hook)
***************
*** 2657,2661 ****
  ;;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete 
noruntime)
  ;;; End:
  
! ;;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46
  ;;; cl-macs.el ends here
--- 2651,2655 ----
  ;;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete 
noruntime)
  ;;; End:
  
! ;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46
  ;;; cl-macs.el ends here




reply via email to

[Prev in Thread] Current Thread [Next in Thread]