/[emacs]/emacs/lisp/emacs-lisp/cl-macs.el
ViewVC logotype

Diff of /emacs/lisp/emacs-lisp/cl-macs.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.34.4.4 by miles, Tue May 11 02:33:56 2004 UTC revision 1.34.4.5 by miles, Wed Dec 8 23:31:40 2004 UTC
# Line 292  ARGLIST allows full Common Lisp conventi Line 292  ARGLIST allows full Common Lisp conventi
292            (laterarg nil) (exactarg nil) minarg)            (laterarg nil) (exactarg nil) minarg)
293        (or num (setq num 0))        (or num (setq num 0))
294        (if (listp (cadr restarg))        (if (listp (cadr restarg))
295            (setq restarg (gensym "--rest--"))            (setq restarg (make-symbol "--cl-rest--"))
296          (setq restarg (cadr restarg)))          (setq restarg (cadr restarg)))
297        (push (list restarg expr) bind-lets)        (push (list restarg expr) bind-lets)
298        (if (eq (car args) '&whole)        (if (eq (car args) '&whole)
# Line 354  ARGLIST allows full Common Lisp conventi Line 354  ARGLIST allows full Common Lisp conventi
354                     (look (list 'memq (list 'quote karg) restarg)))                     (look (list 'memq (list 'quote karg) restarg)))
355                (and def bind-enquote (setq def (list 'quote def)))                (and def bind-enquote (setq def (list 'quote def)))
356                (if (cddr arg)                (if (cddr arg)
357                    (let* ((temp (or (nth 2 arg) (gensym)))                    (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--")))
358                           (val (list 'car (list 'cdr temp))))                           (val (list 'car (list 'cdr temp))))
359                      (cl-do-arglist temp look)                      (cl-do-arglist temp look)
360                      (cl-do-arglist varg                      (cl-do-arglist varg
# Line 377  ARGLIST allows full Common Lisp conventi Line 377  ARGLIST allows full Common Lisp conventi
377        (setq keys (nreverse keys))        (setq keys (nreverse keys))
378        (or (and (eq (car args) '&allow-other-keys) (pop args))        (or (and (eq (car args) '&allow-other-keys) (pop args))
379            (null keys) (= safety 0)            (null keys) (= safety 0)
380            (let* ((var (gensym "--keys--"))            (let* ((var (make-symbol "--cl-keys--"))
381                   (allow '(:allow-other-keys))                   (allow '(:allow-other-keys))
382                   (check (list                   (check (list
383                           'while var                           'while var
# Line 494  If no clause succeeds, case returns nil. Line 494  If no clause succeeds, case returns nil.
494  place of a KEYLIST of one atom.  A KEYLIST of t or `otherwise' is  place of a KEYLIST of one atom.  A KEYLIST of t or `otherwise' is
495  allowed only in the final clause, and matches if no other keys match.  allowed only in the final clause, and matches if no other keys match.
496  Key values are compared by `eql'."  Key values are compared by `eql'."
497    (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym)))    (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
498           (head-list nil)           (head-list nil)
499           (body (cons           (body (cons
500                  'cond                  'cond
# Line 530  Each clause looks like (TYPE BODY...). Line 530  Each clause looks like (TYPE BODY...).
530  satisfies TYPE, the corresponding BODY is evaluated.  If no clause succeeds,  satisfies TYPE, the corresponding BODY is evaluated.  If no clause succeeds,
531  typecase returns nil.  A TYPE of t or `otherwise' is allowed only in the  typecase returns nil.  A TYPE of t or `otherwise' is allowed only in the
532  final clause, and matches if no other keys match."  final clause, and matches if no other keys match."
533    (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym)))    (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
534           (type-list nil)           (type-list nil)
535           (body (cons           (body (cons
536                  'cond                  'cond
# Line 644  Valid clauses are: Line 644  Valid clauses are:
644        (setq args (append args '(cl-end-loop)))        (setq args (append args '(cl-end-loop)))
645        (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause))        (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause))
646        (if loop-finish-flag        (if loop-finish-flag
647            (push (list (list loop-finish-flag t)) loop-bindings))            (push `((,loop-finish-flag t)) loop-bindings))
648        (if loop-first-flag        (if loop-first-flag
649            (progn (push (list (list loop-first-flag t)) loop-bindings)            (progn (push `((,loop-first-flag t)) loop-bindings)
650                   (push (list 'setq loop-first-flag nil) loop-steps)))                   (push `(setq ,loop-first-flag nil) loop-steps)))
651        (let* ((epilogue (nconc (nreverse loop-finally)        (let* ((epilogue (nconc (nreverse loop-finally)
652                                (list (or loop-result-explicit loop-result))))                                (list (or loop-result-explicit loop-result))))
653               (ands (cl-loop-build-ands (nreverse loop-body)))               (ands (cl-loop-build-ands (nreverse loop-body)))
# Line 658  Valid clauses are: Line 658  Valid clauses are:
658                                (list 'block '--cl-finish--                                (list 'block '--cl-finish--
659                                      (subst                                      (subst
660                                       (if (eq (car ands) t) while-body                                       (if (eq (car ands) t) while-body
661                                         (cons (list 'or (car ands)                                         (cons `(or ,(car ands)
662                                                     '(return-from --cl-finish--                                                    (return-from --cl-finish--
663                                                        nil))                                                      nil))
664                                               while-body))                                               while-body))
665                                       '--cl-map loop-map-form))                                       '--cl-map loop-map-form))
666                              (list* 'while (car ands) while-body)))                              (list* 'while (car ands) while-body)))
667                      (if loop-finish-flag                      (if loop-finish-flag
668                          (if (equal epilogue '(nil)) (list loop-result-var)                          (if (equal epilogue '(nil)) (list loop-result-var)
669                            (list (list 'if loop-finish-flag                            `((if ,loop-finish-flag
670                                        (cons 'progn epilogue) loop-result-var)))                                  (progn ,@epilogue) ,loop-result-var)))
671                        epilogue))))                        epilogue))))
672          (if loop-result-var (push (list loop-result-var) loop-bindings))          (if loop-result-var (push (list loop-result-var) loop-bindings))
673          (while loop-bindings          (while loop-bindings
# Line 682  Valid clauses are: Line 682  Valid clauses are:
682              (setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))              (setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))
683          (list* 'block loop-name body)))))          (list* 'block loop-name body)))))
684    
685  (defun cl-parse-loop-clause ()   ; uses args, loop-*  (defun cl-parse-loop-clause ()          ; uses args, loop-*
686    (let ((word (pop args))    (let ((word (pop args))
687          (hash-types '(hash-key hash-keys hash-value hash-values))          (hash-types '(hash-key hash-keys hash-value hash-values))
688          (key-types '(key-code key-codes key-seq key-seqs          (key-types '(key-code key-codes key-seq key-seqs
# Line 715  Valid clauses are: Line 715  Valid clauses are:
715        (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)        (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
716              (ands nil))              (ands nil))
717          (while          (while
718              (let ((var (or (pop args) (gensym))))              (let ((var (or (pop args) (make-symbol "--cl-var--"))))
719                (setq word (pop args))                (setq word (pop args))
720                (if (eq word 'being) (setq word (pop args)))                (if (eq word 'being) (setq word (pop args)))
721                (if (memq word '(the each)) (setq word (pop args)))                (if (memq word '(the each)) (setq word (pop args)))
# Line 738  Valid clauses are: Line 738  Valid clauses are:
738                                         '(to upto downto above below))                                         '(to upto downto above below))
739                                   (cl-pop2 args)))                                   (cl-pop2 args)))
740                         (step (and (eq (car args) 'by) (cl-pop2 args)))                         (step (and (eq (car args) 'by) (cl-pop2 args)))
741                         (end-var (and (not (cl-const-expr-p end)) (gensym)))                         (end-var (and (not (cl-const-expr-p end))
742                                         (make-symbol "--cl-var--")))
743                         (step-var (and (not (cl-const-expr-p step))                         (step-var (and (not (cl-const-expr-p step))
744                                        (gensym))))                                        (make-symbol "--cl-var--"))))
745                    (and step (numberp step) (<= step 0)                    (and step (numberp step) (<= step 0)
746                         (error "Loop `by' value is not positive: %s" step))                         (error "Loop `by' value is not positive: %s" step))
747                    (push (list var (or start 0)) loop-for-bindings)                    (push (list var (or start 0)) loop-for-bindings)
748                    (if end-var (push (list end-var end) loop-for-bindings))                    (if end-var (push (list end-var end) loop-for-bindings))
749                    (if step-var (push (list step-var step)                    (if step-var (push (list step-var step)
750                                          loop-for-bindings))                                       loop-for-bindings))
751                    (if end                    (if end
752                        (push (list                        (push (list
753                                  (if down (if excl '> '>=) (if excl '< '<=))                               (if down (if excl '> '>=) (if excl '< '<=))
754                                  var (or end-var end)) loop-body))                               var (or end-var end)) loop-body))
755                    (push (list var (list (if down '- '+) var                    (push (list var (list (if down '- '+) var
756                                             (or step-var step 1)))                                          (or step-var step 1)))
757                             loop-for-steps)))                          loop-for-steps)))
758    
759                 ((memq word '(in in-ref on))                 ((memq word '(in in-ref on))
760                  (let* ((on (eq word 'on))                  (let* ((on (eq word 'on))
761                         (temp (if (and on (symbolp var)) var (gensym))))                         (temp (if (and on (symbolp var))
762                                     var (make-symbol "--cl-var--"))))
763                    (push (list temp (pop args)) loop-for-bindings)                    (push (list temp (pop args)) loop-for-bindings)
764                    (push (list 'consp temp) loop-body)                    (push (list 'consp temp) loop-body)
765                    (if (eq word 'in-ref)                    (if (eq word 'in-ref)
# Line 766  Valid clauses are: Line 768  Valid clauses are:
768                          (progn                          (progn
769                            (push (list var nil) loop-for-bindings)                            (push (list var nil) loop-for-bindings)
770                            (push (list var (if on temp (list 'car temp)))                            (push (list var (if on temp (list 'car temp)))
771                                     loop-for-sets))))                                  loop-for-sets))))
772                    (push (list temp                    (push (list temp
773                                   (if (eq (car args) 'by)                                (if (eq (car args) 'by)
774                                       (let ((step (cl-pop2 args)))                                    (let ((step (cl-pop2 args)))
775                                         (if (and (memq (car-safe step)                                      (if (and (memq (car-safe step)
776                                                        '(quote function                                                     '(quote function
777                                                                function*))                                                             function*))
778                                                  (symbolp (nth 1 step)))                                               (symbolp (nth 1 step)))
779                                             (list (nth 1 step) temp)                                          (list (nth 1 step) temp)
780                                           (list 'funcall step temp)))                                        (list 'funcall step temp)))
781                                     (list 'cdr temp)))                                  (list 'cdr temp)))
782                             loop-for-steps)))                          loop-for-steps)))
783    
784                 ((eq word '=)                 ((eq word '=)
785                  (let* ((start (pop args))                  (let* ((start (pop args))
# Line 785  Valid clauses are: Line 787  Valid clauses are:
787                    (push (list var nil) loop-for-bindings)                    (push (list var nil) loop-for-bindings)
788                    (if (or ands (eq (car args) 'and))                    (if (or ands (eq (car args) 'and))
789                        (progn                        (progn
790                          (push (list var                          (push `(,var
791                                         (list 'if                                  (if ,(or loop-first-flag
792                                               (or loop-first-flag                                           (setq loop-first-flag
793                                                   (setq loop-first-flag                                                 (make-symbol "--cl-var--")))
794                                                         (gensym)))                                      ,start ,var))
795                                               start var))                                loop-for-sets)
                                  loop-for-sets)  
796                          (push (list var then) loop-for-steps))                          (push (list var then) loop-for-steps))
797                      (push (list var                      (push (list var
798                                     (if (eq start then) start                                  (if (eq start then) start
799                                       (list 'if                                    `(if ,(or loop-first-flag
800                                             (or loop-first-flag                                              (setq loop-first-flag
801                                                 (setq loop-first-flag (gensym)))                                                    (make-symbol "--cl-var--")))
802                                             start then)))                                         ,start ,then)))
803                               loop-for-sets))))                            loop-for-sets))))
804    
805                 ((memq word '(across across-ref))                 ((memq word '(across across-ref))
806                  (let ((temp-vec (gensym)) (temp-idx (gensym)))                  (let ((temp-vec (make-symbol "--cl-vec--"))
807                          (temp-idx (make-symbol "--cl-idx--")))
808                    (push (list temp-vec (pop args)) loop-for-bindings)                    (push (list temp-vec (pop args)) loop-for-bindings)
809                    (push (list temp-idx -1) loop-for-bindings)                    (push (list temp-idx -1) loop-for-bindings)
810                    (push (list '< (list 'setq temp-idx (list '1+ temp-idx))                    (push (list '< (list 'setq temp-idx (list '1+ temp-idx))
811                                   (list 'length temp-vec)) loop-body)                                (list 'length temp-vec)) loop-body)
812                    (if (eq word 'across-ref)                    (if (eq word 'across-ref)
813                        (push (list var (list 'aref temp-vec temp-idx))                        (push (list var (list 'aref temp-vec temp-idx))
814                                 loop-symbol-macs)                              loop-symbol-macs)
815                      (push (list var nil) loop-for-bindings)                      (push (list var nil) loop-for-bindings)
816                      (push (list var (list 'aref temp-vec temp-idx))                      (push (list var (list 'aref temp-vec temp-idx))
817                               loop-for-sets))))                            loop-for-sets))))
818    
819                 ((memq word '(element elements))                 ((memq word '(element elements))
820                  (let ((ref (or (memq (car args) '(in-ref of-ref))                  (let ((ref (or (memq (car args) '(in-ref of-ref))
821                                 (and (not (memq (car args) '(in of)))                                 (and (not (memq (car args) '(in of)))
822                                      (error "Expected `of'"))))                                      (error "Expected `of'"))))
823                        (seq (cl-pop2 args))                        (seq (cl-pop2 args))
824                        (temp-seq (gensym))                        (temp-seq (make-symbol "--cl-seq--"))
825                        (temp-idx (if (eq (car args) 'using)                        (temp-idx (if (eq (car args) 'using)
826                                      (if (and (= (length (cadr args)) 2)                                      (if (and (= (length (cadr args)) 2)
827                                               (eq (caadr args) 'index))                                               (eq (caadr args) 'index))
828                                          (cadr (cl-pop2 args))                                          (cadr (cl-pop2 args))
829                                        (error "Bad `using' clause"))                                        (error "Bad `using' clause"))
830                                    (gensym))))                                    (make-symbol "--cl-idx--"))))
831                    (push (list temp-seq seq) loop-for-bindings)                    (push (list temp-seq seq) loop-for-bindings)
832                    (push (list temp-idx 0) loop-for-bindings)                    (push (list temp-idx 0) loop-for-bindings)
833                    (if ref                    (if ref
834                        (let ((temp-len (gensym)))                        (let ((temp-len (make-symbol "--cl-len--")))
835                          (push (list temp-len (list 'length temp-seq))                          (push (list temp-len (list 'length temp-seq))
836                                   loop-for-bindings)                                loop-for-bindings)
837                          (push (list var (list 'elt temp-seq temp-idx))                          (push (list var (list 'elt temp-seq temp-idx))
838                                   loop-symbol-macs)                                loop-symbol-macs)
839                          (push (list '< temp-idx temp-len) loop-body))                          (push (list '< temp-idx temp-len) loop-body))
840                      (push (list var nil) loop-for-bindings)                      (push (list var nil) loop-for-bindings)
841                      (push (list 'and temp-seq                      (push (list 'and temp-seq
842                                     (list 'or (list 'consp temp-seq)                                  (list 'or (list 'consp temp-seq)
843                                           (list '< temp-idx                                        (list '< temp-idx
844                                                 (list 'length temp-seq))))                                              (list 'length temp-seq))))
845                               loop-body)                            loop-body)
846                      (push (list var (list 'if (list 'consp temp-seq)                      (push (list var (list 'if (list 'consp temp-seq)
847                                               (list 'pop temp-seq)                                            (list 'pop temp-seq)
848                                               (list 'aref temp-seq temp-idx)))                                            (list 'aref temp-seq temp-idx)))
849                               loop-for-sets))                            loop-for-sets))
850                    (push (list temp-idx (list '1+ temp-idx))                    (push (list temp-idx (list '1+ temp-idx))
851                             loop-for-steps)))                          loop-for-steps)))
852    
853                 ((memq word hash-types)                 ((memq word hash-types)
854                  (or (memq (car args) '(in of)) (error "Expected `of'"))                  (or (memq (car args) '(in of)) (error "Expected `of'"))
# Line 857  Valid clauses are: Line 859  Valid clauses are:
859                                             (not (eq (caadr args) word)))                                             (not (eq (caadr args) word)))
860                                        (cadr (cl-pop2 args))                                        (cadr (cl-pop2 args))
861                                      (error "Bad `using' clause"))                                      (error "Bad `using' clause"))
862                                  (gensym))))                                  (make-symbol "--cl-var--"))))
863                    (if (memq word '(hash-value hash-values))                    (if (memq word '(hash-value hash-values))
864                        (setq var (prog1 other (setq other var))))                        (setq var (prog1 other (setq other var))))
865                    (setq loop-map-form                    (setq loop-map-form
866                          (list 'maphash (list 'function                          `(maphash (lambda (,var ,other) . --cl-map) ,table))))
                                              (list* 'lambda (list var other)  
                                                     '--cl-map)) table))))  
867    
868                 ((memq word '(symbol present-symbol external-symbol                 ((memq word '(symbol present-symbol external-symbol
869                               symbols present-symbols external-symbols))                               symbols present-symbols external-symbols))
870                  (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args))))                  (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args))))
871                    (setq loop-map-form                    (setq loop-map-form
872                          (list 'mapatoms (list 'function                          `(mapatoms (lambda (,var) . --cl-map) ,ob))))
                                               (list* 'lambda (list var)  
                                                      '--cl-map)) ob))))  
873    
874                 ((memq word '(overlay overlays extent extents))                 ((memq word '(overlay overlays extent extents))
875                  (let ((buf nil) (from nil) (to nil))                  (let ((buf nil) (from nil) (to nil))
# Line 880  Valid clauses are: Line 878  Valid clauses are:
878                            ((eq (car args) 'to) (setq to (cl-pop2 args)))                            ((eq (car args) 'to) (setq to (cl-pop2 args)))
879                            (t (setq buf (cl-pop2 args)))))                            (t (setq buf (cl-pop2 args)))))
880                    (setq loop-map-form                    (setq loop-map-form
881                          (list 'cl-map-extents                          `(cl-map-extents
882                                (list 'function (list 'lambda (list var (gensym))                            (lambda (,var ,(make-symbol "--cl-var--"))
883                                                      '(progn . --cl-map) nil))                              (progn . --cl-map) nil)
884                                buf from to))))                            ,buf ,from ,to))))
885    
886                 ((memq word '(interval intervals))                 ((memq word '(interval intervals))
887                  (let ((buf nil) (prop nil) (from nil) (to nil)                  (let ((buf nil) (prop nil) (from nil) (to nil)
888                        (var1 (gensym)) (var2 (gensym)))                        (var1 (make-symbol "--cl-var1--"))
889                          (var2 (make-symbol "--cl-var2--")))
890                    (while (memq (car args) '(in of property from to))                    (while (memq (car args) '(in of property from to))
891                      (cond ((eq (car args) 'from) (setq from (cl-pop2 args)))                      (cond ((eq (car args) 'from) (setq from (cl-pop2 args)))
892                            ((eq (car args) 'to) (setq to (cl-pop2 args)))                            ((eq (car args) 'to) (setq to (cl-pop2 args)))
# Line 898  Valid clauses are: Line 897  Valid clauses are:
897                        (setq var1 (car var) var2 (cdr var))                        (setq var1 (car var) var2 (cdr var))
898                      (push (list var (list 'cons var1 var2)) loop-for-sets))                      (push (list var (list 'cons var1 var2)) loop-for-sets))
899                    (setq loop-map-form                    (setq loop-map-form
900                          (list 'cl-map-intervals                          `(cl-map-intervals
901                                (list 'function (list 'lambda (list var1 var2)                            (lambda (,var1 ,var2) . --cl-map)
902                                                      '(progn . --cl-map)))                            ,buf ,prop ,from ,to))))
                               buf prop from to))))  
903    
904                 ((memq word key-types)                 ((memq word key-types)
905                  (or (memq (car args) '(in of)) (error "Expected `of'"))                  (or (memq (car args) '(in of)) (error "Expected `of'"))
# Line 912  Valid clauses are: Line 910  Valid clauses are:
910                                            (not (eq (caadr args) word)))                                            (not (eq (caadr args) word)))
911                                       (cadr (cl-pop2 args))                                       (cadr (cl-pop2 args))
912                                     (error "Bad `using' clause"))                                     (error "Bad `using' clause"))
913                                 (gensym))))                                 (make-symbol "--cl-var--"))))
914                    (if (memq word '(key-binding key-bindings))                    (if (memq word '(key-binding key-bindings))
915                        (setq var (prog1 other (setq other var))))                        (setq var (prog1 other (setq other var))))
916                    (setq loop-map-form                    (setq loop-map-form
917                          (list (if (memq word '(key-seq key-seqs))                          `(,(if (memq word '(key-seq key-seqs))
918                                    'cl-map-keymap-recursively 'map-keymap)                                 'cl-map-keymap-recursively 'map-keymap)
919                                (list 'function (list* 'lambda (list var other)                            (lambda (,var ,other) . --cl-map) ,map))))
                                                      '--cl-map)) map))))  
920    
921                 ((memq word '(frame frames screen screens))                 ((memq word '(frame frames screen screens))
922                  (let ((temp (gensym)))                  (let ((temp (make-symbol "--cl-var--")))
923                    (push (list var  '(selected-frame))                    (push (list var  '(selected-frame))
924                             loop-for-bindings)                          loop-for-bindings)
925                    (push (list temp nil) loop-for-bindings)                    (push (list temp nil) loop-for-bindings)
926                    (push (list 'prog1 (list 'not (list 'eq var temp))                    (push (list 'prog1 (list 'not (list 'eq var temp))
927                                   (list 'or temp (list 'setq temp var)))                                (list 'or temp (list 'setq temp var)))
928                             loop-body)                          loop-body)
929                    (push (list var (list 'next-frame var))                    (push (list var (list 'next-frame var))
930                             loop-for-steps)))                          loop-for-steps)))
931    
932                 ((memq word '(window windows))                 ((memq word '(window windows))
933                  (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))                  (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
934                        (temp (gensym)))                        (temp (make-symbol "--cl-var--")))
935                    (push (list var (if scr                    (push (list var (if scr
936                                           (list 'frame-selected-window scr)                                        (list 'frame-selected-window scr)
937                                         '(selected-window)))                                      '(selected-window)))
938                             loop-for-bindings)                          loop-for-bindings)
939                    (push (list temp nil) loop-for-bindings)                    (push (list temp nil) loop-for-bindings)
940                    (push (list 'prog1 (list 'not (list 'eq var temp))                    (push (list 'prog1 (list 'not (list 'eq var temp))
941                                   (list 'or temp (list 'setq temp var)))                                (list 'or temp (list 'setq temp var)))
942                             loop-body)                          loop-body)
943                    (push (list var (list 'next-window var)) loop-for-steps)))                    (push (list var (list 'next-window var)) loop-for-steps)))
944    
945                 (t                 (t
# Line 960  Valid clauses are: Line 957  Valid clauses are:
957                                       loop-bindings)))                                       loop-bindings)))
958          (if loop-for-sets          (if loop-for-sets
959              (push (list 'progn              (push (list 'progn
960                             (cl-loop-let (nreverse loop-for-sets) 'setq ands)                          (cl-loop-let (nreverse loop-for-sets) 'setq ands)
961                             t) loop-body))                          t) loop-body))
962          (if loop-for-steps          (if loop-for-steps
963              (push (cons (if ands 'psetq 'setq)              (push (cons (if ands 'psetq 'setq)
964                             (apply 'append (nreverse loop-for-steps)))                          (apply 'append (nreverse loop-for-steps)))
965                       loop-steps))))                    loop-steps))))
966    
967       ((eq word 'repeat)       ((eq word 'repeat)
968        (let ((temp (gensym)))        (let ((temp (make-symbol "--cl-var--")))
969          (push (list (list temp (pop args))) loop-bindings)          (push (list (list temp (pop args))) loop-bindings)
970          (push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))          (push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))
971    
# Line 978  Valid clauses are: Line 975  Valid clauses are:
975          (if (eq var loop-accum-var)          (if (eq var loop-accum-var)
976              (push (list 'progn (list 'push what var) t) loop-body)              (push (list 'progn (list 'push what var) t) loop-body)
977            (push (list 'progn            (push (list 'progn
978                           (list 'setq var (list 'nconc var (list 'list what)))                        (list 'setq var (list 'nconc var (list 'list what)))
979                           t) loop-body))))                        t) loop-body))))
980    
981       ((memq word '(nconc nconcing append appending))       ((memq word '(nconc nconcing append appending))
982        (let ((what (pop args))        (let ((what (pop args))
983              (var (cl-loop-handle-accum nil 'nreverse)))              (var (cl-loop-handle-accum nil 'nreverse)))
984          (push (list 'progn          (push (list 'progn
985                         (list 'setq var                      (list 'setq var
986                               (if (eq var loop-accum-var)                            (if (eq var loop-accum-var)
987                                   (list 'nconc                                (list 'nconc
988                                         (list (if (memq word '(nconc nconcing))                                      (list (if (memq word '(nconc nconcing))
989                                                   'nreverse 'reverse)                                                'nreverse 'reverse)
990                                               what)                                            what)
991                                         var)                                      var)
992                                 (list (if (memq word '(nconc nconcing))                              (list (if (memq word '(nconc nconcing))
993                                           'nconc 'append)                                        'nconc 'append)
994                                       var what))) t) loop-body)))                                    var what))) t) loop-body)))
995    
996       ((memq word '(concat concating))       ((memq word '(concat concating))
997        (let ((what (pop args))        (let ((what (pop args))
# Line 1018  Valid clauses are: Line 1015  Valid clauses are:
1015    
1016       ((memq word '(minimize minimizing maximize maximizing))       ((memq word '(minimize minimizing maximize maximizing))
1017        (let* ((what (pop args))        (let* ((what (pop args))
1018               (temp (if (cl-simple-expr-p what) what (gensym)))               (temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--")))
1019               (var (cl-loop-handle-accum nil))               (var (cl-loop-handle-accum nil))
1020               (func (intern (substring (symbol-name word) 0 3)))               (func (intern (substring (symbol-name word) 0 3)))
1021               (set (list 'setq var (list 'if var (list func var temp) temp))))               (set (list 'setq var (list 'if var (list func var temp) temp))))
1022          (push (list 'progn (if (eq temp what) set          (push (list 'progn (if (eq temp what) set
1023                                  (list 'let (list (list temp what)) set))                               (list 'let (list (list temp what)) set))
1024                         t) loop-body)))                      t) loop-body)))
1025    
1026       ((eq word 'with)       ((eq word 'with)
1027        (let ((bindings nil))        (let ((bindings nil))
1028          (while (progn (push (list (pop args)          (while (progn (push (list (pop args)
1029                                       (and (eq (car args) '=) (cl-pop2 args)))                                    (and (eq (car args) '=) (cl-pop2 args)))
1030                                 bindings)                              bindings)
1031                        (eq (car args) 'and))                        (eq (car args) 'and))
1032            (pop args))            (pop args))
1033          (push (nreverse bindings) loop-bindings)))          (push (nreverse bindings) loop-bindings)))
# Line 1042  Valid clauses are: Line 1039  Valid clauses are:
1039        (push (list 'not (pop args)) loop-body))        (push (list 'not (pop args)) loop-body))
1040    
1041       ((eq word 'always)       ((eq word 'always)
1042        (or loop-finish-flag (setq loop-finish-flag (gensym)))        (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
1043        (push (list 'setq loop-finish-flag (pop args)) loop-body)        (push (list 'setq loop-finish-flag (pop args)) loop-body)
1044        (setq loop-result t))        (setq loop-result t))
1045    
1046       ((eq word 'never)       ((eq word 'never)
1047        (or loop-finish-flag (setq loop-finish-flag (gensym)))        (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
1048        (push (list 'setq loop-finish-flag (list 'not (pop args)))        (push (list 'setq loop-finish-flag (list 'not (pop args)))
1049                 loop-body)              loop-body)
1050        (setq loop-result t))        (setq loop-result t))
1051    
1052       ((eq word 'thereis)       ((eq word 'thereis)
1053        (or loop-finish-flag (setq loop-finish-flag (gensym)))        (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
1054        (or loop-result-var (setq loop-result-var (gensym)))        (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
1055        (push (list 'setq loop-finish-flag        (push (list 'setq loop-finish-flag
1056                       (list 'not (list 'setq loop-result-var (pop args))))                    (list 'not (list 'setq loop-result-var (pop args))))
1057                 loop-body))              loop-body))
1058    
1059       ((memq word '(if when unless))       ((memq word '(if when unless))
1060        (let* ((cond (pop args))        (let* ((cond (pop args))
# Line 1074  Valid clauses are: Line 1071  Valid clauses are:
1071          (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))          (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
1072                            (if simple (nth 1 else) (list (nth 2 else))))))                            (if simple (nth 1 else) (list (nth 2 else))))))
1073            (if (cl-expr-contains form 'it)            (if (cl-expr-contains form 'it)
1074                (let ((temp (gensym)))                (let ((temp (make-symbol "--cl-var--")))
1075                  (push (list temp) loop-bindings)                  (push (list temp) loop-bindings)
1076                  (setq form (list* 'if (list 'setq temp cond)                  (setq form (list* 'if (list 'setq temp cond)
1077                                    (subst temp 'it form))))                                    (subst temp 'it form))))
# Line 1088  Valid clauses are: Line 1085  Valid clauses are:
1085          (push (cons 'progn (nreverse (cons t body))) loop-body)))          (push (cons 'progn (nreverse (cons t body))) loop-body)))
1086    
1087       ((eq word 'return)       ((eq word 'return)
1088        (or loop-finish-flag (setq loop-finish-flag (gensym)))        (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--")))
1089        (or loop-result-var (setq loop-result-var (gensym)))        (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
1090        (push (list 'setq loop-result-var (pop args)        (push (list 'setq loop-result-var (pop args)
1091                       loop-finish-flag nil) loop-body))                    loop-finish-flag nil) loop-body))
1092    
1093       (t       (t
1094        (let ((handler (and (symbolp word) (get word 'cl-loop-handler))))        (let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
# Line 1109  Valid clauses are: Line 1106  Valid clauses are:
1106             (setq par nil p specs)             (setq par nil p specs)
1107             (while p             (while p
1108               (or (cl-const-expr-p (cadar p))               (or (cl-const-expr-p (cadar p))
1109                   (let ((temp (gensym)))                   (let ((temp (make-symbol "--cl-var--")))
1110                     (push (list temp (cadar p)) temps)                     (push (list temp (cadar p)) temps)
1111                     (setcar (cdar p) temp)))                     (setcar (cdar p) temp)))
1112               (setq p (cdr p)))))               (setq p (cdr p)))))
# Line 1119  Valid clauses are: Line 1116  Valid clauses are:
1116                   (expr (cadr (pop specs)))                   (expr (cadr (pop specs)))
1117                   (temp (cdr (or (assq spec loop-destr-temps)                   (temp (cdr (or (assq spec loop-destr-temps)
1118                                  (car (push (cons spec (or (last spec 0)                                  (car (push (cons spec (or (last spec 0)
1119                                                               (gensym)))                                                            (make-symbol "--cl-var--")))
1120                                                loop-destr-temps))))))                                             loop-destr-temps))))))
1121              (push (list temp expr) new)              (push (list temp expr) new)
1122              (while (consp spec)              (while (consp spec)
1123                (push (list (pop spec)                (push (list (pop spec)
# Line 1143  Valid clauses are: Line 1140  Valid clauses are:
1140          var)          var)
1141      (or loop-accum-var      (or loop-accum-var
1142          (progn          (progn
1143            (push (list (list (setq loop-accum-var (gensym)) def))            (push (list (list (setq loop-accum-var (make-symbol "--cl-var--")) def))
1144                     loop-bindings)                     loop-bindings)
1145            (setq loop-result (if func (list func loop-accum-var)            (setq loop-result (if func (list func loop-accum-var)
1146                                loop-accum-var))                                loop-accum-var))
# Line 1214  Evaluate BODY with VAR bound to each `ca Line 1211  Evaluate BODY with VAR bound to each `ca
1211  Then evaluate RESULT to get return value, default nil.  Then evaluate RESULT to get return value, default nil.
1212    
1213  \(fn (VAR LIST [RESULT]) BODY...)"  \(fn (VAR LIST [RESULT]) BODY...)"
1214    (let ((temp (gensym "--dolist-temp--")))    (let ((temp (make-symbol "--cl-dolist-temp--")))
1215      (list 'block nil      (list 'block nil
1216            (list* 'let (list (list temp (nth 1 spec)) (car spec))            (list* 'let (list (list temp (nth 1 spec)) (car spec))
1217                   (list* 'while temp (list 'setq (car spec) (list 'car temp))                   (list* 'while temp (list 'setq (car spec) (list 'car temp))
# Line 1231  to COUNT, exclusive.  Then evaluate RESU Line 1228  to COUNT, exclusive.  Then evaluate RESU
1228  nil.  nil.
1229    
1230  \(fn (VAR COUNT [RESULT]) BODY...)"  \(fn (VAR COUNT [RESULT]) BODY...)"
1231    (let ((temp (gensym "--dotimes-temp--")))    (let ((temp (make-symbol "--cl-dotimes-temp--")))
1232      (list 'block nil      (list 'block nil
1233            (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0))            (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0))
1234                   (list* 'while (list '< (car spec) temp)                   (list* 'while (list '< (car spec) temp)
# Line 1317  Unlike `flet', this macro is fully compl Line 1314  Unlike `flet', this macro is fully compl
1314  \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"  \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
1315    (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))    (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
1316      (while bindings      (while bindings
1317        (let ((var (gensym)))        (let ((var (make-symbol "--cl-var--")))
1318          (push var vars)          (push var vars)
1319          (push (list 'function* (cons 'lambda (cdar bindings))) sets)          (push (list 'function* (cons 'lambda (cdar bindings))) sets)
1320          (push var sets)          (push var sets)
# Line 1370  lexical closures as in Common Lisp." Line 1367  lexical closures as in Common Lisp."
1367           (vars (mapcar (function           (vars (mapcar (function
1368                          (lambda (x)                          (lambda (x)
1369                            (or (consp x) (setq x (list x)))                            (or (consp x) (setq x (list x)))
1370                            (push (gensym (format "--%s--" (car x)))                            (push (make-symbol (format "--cl-%s--" (car x)))
1371                                     cl-closure-vars)                                  cl-closure-vars)
1372                            (set (car cl-closure-vars) [bad-lexical-ref])                            (set (car cl-closure-vars) [bad-lexical-ref])
1373                            (list (car x) (cadr x) (car cl-closure-vars))))                            (list (car x) (cadr x) (car cl-closure-vars))))
1374                         bindings))                         bindings))
# Line 1432  simulate true multiple return values.  F Line 1429  simulate true multiple return values.  F
1429  a synonym for (list A B C).  a synonym for (list A B C).
1430    
1431  \(fn (SYM SYM...) FORM BODY)"  \(fn (SYM SYM...) FORM BODY)"
1432    (let ((temp (gensym)) (n -1))    (let ((temp (make-symbol "--cl-var--")) (n -1))
1433      (list* 'let* (cons (list temp form)      (list* 'let* (cons (list temp form)
1434                         (mapcar (function                         (mapcar (function
1435                                  (lambda (v)                                  (lambda (v)
# Line 1451  values.  For compatibility, (values A B Line 1448  values.  For compatibility, (values A B
1448    (cond ((null vars) (list 'progn form nil))    (cond ((null vars) (list 'progn form nil))
1449          ((null (cdr vars)) (list 'setq (car vars) (list 'car form)))          ((null (cdr vars)) (list 'setq (car vars) (list 'car form)))
1450          (t          (t
1451           (let* ((temp (gensym)) (n 0))           (let* ((temp (make-symbol "--cl-var--")) (n 0))
1452             (list 'let (list (list temp form))             (list 'let (list (list temp form))
1453                   (list 'prog1 (list 'setq (pop vars) (list 'car temp))                   (list 'prog1 (list 'setq (pop vars) (list 'car temp))
1454                         (cons 'setq (apply 'nconc                         (cons 'setq (apply 'nconc
# Line 1590  Example: (defsetf nth (n x) (v) (list 's Line 1587  Example: (defsetf nth (n x) (v) (list 's
1587            (setq largsr largs tempsr temps))            (setq largsr largs tempsr temps))
1588          (let ((p1 largs) (p2 temps))          (let ((p1 largs) (p2 temps))
1589            (while p1            (while p1
1590              (setq lets1 (cons (list (car p2)              (setq lets1 (cons `(,(car p2)
1591                                      (list 'gensym (format "--%s--" (car p1))))                                  (make-symbol ,(format "--cl-%s--" (car p1))))
1592                                lets1)                                lets1)
1593                    lets2 (cons (list (car p1) (car p2)) lets2)                    lets2 (cons (list (car p1) (car p2)) lets2)
1594                    p1 (cdr p1) p2 (cdr p2))))                    p1 (cdr p1) p2 (cdr p2))))
1595          (if restarg (setq lets2 (cons (list restarg rest-temps) lets2)))          (if restarg (setq lets2 (cons (list restarg rest-temps) lets2)))
1596          (append (list 'define-setf-method func arg1)          `(define-setf-method ,func ,arg1
1597                  (and docstr (list docstr))             ,@(and docstr (list docstr))
1598                  (list             (let*
1599                   (list 'let*                 ,(nreverse
1600                         (nreverse                   (cons `(,store-temp
1601                          (cons (list store-temp                           (make-symbol ,(format "--cl-%s--" store-var)))
1602                                      (list 'gensym (format "--%s--" store-var)))                         (if restarg
1603                                (if restarg                             `((,rest-temps
1604                                    (append                                (mapcar (lambda (_) (make-symbol "--cl-var--"))
1605                                     (list                                        ,restarg))
1606                                      (list rest-temps                               ,@lets1)
1607                                            (list 'mapcar '(quote gensym)                           lets1)))
1608                                                  restarg)))               (list                      ; 'values
1609                                     lets1)                (,(if restarg 'list* 'list) ,@tempsr)
1610                                  lets1)))                (,(if restarg 'list* 'list) ,@largsr)
1611                         (list 'list  ; 'values                (list ,store-temp)
1612                               (cons (if restarg 'list* 'list) tempsr)                (let*
1613                               (cons (if restarg 'list* 'list) largsr)                    ,(nreverse
1614                               (list 'list store-temp)                      (cons (list store-var store-temp)
1615                               (cons 'let*                            lets2))
1616                                     (cons (nreverse                  ,@args)
1617                                            (cons (list store-var store-temp)                (,(if restarg 'list* 'list)
1618                                                  lets2))                 ,@(cons (list 'quote func) tempsr))))))
1619                                           args))      `(defsetf ,func (&rest args) (store)
1620                               (cons (if restarg 'list* 'list)         ,(let ((call `(cons ',arg1
1621                                     (cons (list 'quote func) tempsr)))))))                             (append args (list store)))))
1622      (list 'defsetf func '(&rest args) '(store)            (if (car args)
1623            (let ((call (list 'cons (list 'quote arg1)                `(list 'progn ,call store)
1624                              '(append args (list store)))))              call)))))
             (if (car args)  
                 (list 'list '(quote progn) call 'store)  
               call)))))  
1625    
1626  ;;; Some standard place types from Common Lisp.  ;;; Some standard place types from Common Lisp.
1627  (defsetf aref aset)  (defsetf aref aset)
# Line 1781  Example: (defsetf nth (n x) (v) (list 's Line 1775  Example: (defsetf nth (n x) (v) (list 's
1775    
1776  (define-setf-method nthcdr (n place)  (define-setf-method nthcdr (n place)
1777    (let ((method (get-setf-method place cl-macro-environment))    (let ((method (get-setf-method place cl-macro-environment))
1778          (n-temp (gensym "--nthcdr-n--"))          (n-temp (make-symbol "--cl-nthcdr-n--"))
1779          (store-temp (gensym "--nthcdr-store--")))          (store-temp (make-symbol "--cl-nthcdr-store--")))
1780      (list (cons n-temp (car method))      (list (cons n-temp (car method))
1781            (cons n (nth 1 method))            (cons n (nth 1 method))
1782            (list store-temp)            (list store-temp)
# Line 1794  Example: (defsetf nth (n x) (v) (list 's Line 1788  Example: (defsetf nth (n x) (v) (list 's
1788    
1789  (define-setf-method getf (place tag &optional def)  (define-setf-method getf (place tag &optional def)
1790    (let ((method (get-setf-method place cl-macro-environment))    (let ((method (get-setf-method place cl-macro-environment))
1791          (tag-temp (gensym "--getf-tag--"))          (tag-temp (make-symbol "--cl-getf-tag--"))
1792          (def-temp (gensym "--getf-def--"))          (def-temp (make-symbol "--cl-getf-def--"))
1793          (store-temp (gensym "--getf-store--")))          (store-temp (make-symbol "--cl-getf-store--")))
1794      (list (append (car method) (list tag-temp def-temp))      (list (append (car method) (list tag-temp def-temp))
1795            (append (nth 1 method) (list tag def))            (append (nth 1 method) (list tag def))
1796            (list store-temp)            (list store-temp)
# Line 1808  Example: (defsetf nth (n x) (v) (list 's Line 1802  Example: (defsetf nth (n x) (v) (list 's
1802    
1803  (define-setf-method substring (place from &optional to)  (define-setf-method substring (place from &optional to)
1804    (let ((method (get-setf-method place cl-macro-environment))    (let ((method (get-setf-method place cl-macro-environment))
1805          (from-temp (gensym "--substring-from--"))          (from-temp (make-symbol "--cl-substring-from--"))
1806          (to-temp (gensym "--substring-to--"))          (to-temp (make-symbol "--cl-substring-to--"))
1807          (store-temp (gensym "--substring-store--")))          (store-temp (make-symbol "--cl-substring-store--")))
1808      (list (append (car method) (list from-temp to-temp))      (list (append (car method) (list from-temp to-temp))
1809            (append (nth 1 method) (list from to))            (append (nth 1 method) (list from to))
1810            (list store-temp)            (list store-temp)
# Line 1826  Example: (defsetf nth (n x) (v) (list 's Line 1820  Example: (defsetf nth (n x) (v) (list 's
1820  PLACE may be any Lisp form which can appear as the PLACE argument to  PLACE may be any Lisp form which can appear as the PLACE argument to
1821  a macro like `setf' or `incf'."  a macro like `setf' or `incf'."
1822    (if (symbolp place)    (if (symbolp place)
1823        (let ((temp (gensym "--setf--")))        (let ((temp (make-symbol "--cl-setf--")))
1824          (list nil nil (list temp) (list 'setq place temp) place))          (list nil nil (list temp) (list 'setq place temp) place))
1825      (or (and (symbolp (car place))      (or (and (symbolp (car place))
1826               (let* ((func (car place))               (let* ((func (car place))
# Line 1933  before assigning any PLACEs to the corre Line 1927  before assigning any PLACEs to the corre
1927    (if (cl-simple-expr-p place)    (if (cl-simple-expr-p place)
1928        (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place)))        (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place)))
1929      (let* ((method (cl-setf-do-modify place t))      (let* ((method (cl-setf-do-modify place t))
1930             (temp (gensym "--pop--")))             (temp (make-symbol "--cl-pop--")))
1931        (list 'let*        (list 'let*
1932              (append (car method)              (append (car method)
1933                      (list (list temp (nth 2 method))))                      (list (list temp (nth 2 method))))
# Line 1946  before assigning any PLACEs to the corre Line 1940  before assigning any PLACEs to the corre
1940  PLACE may be a symbol, or any generalized variable allowed by `setf'.  PLACE may be a symbol, or any generalized variable allowed by `setf'.
1941  The form returns true if TAG was found and removed, nil otherwise."  The form returns true if TAG was found and removed, nil otherwise."
1942    (let* ((method (cl-setf-do-modify place t))    (let* ((method (cl-setf-do-modify place t))
1943           (tag-temp (and (not (cl-const-expr-p tag)) (gensym "--remf-tag--")))           (tag-temp (and (not (cl-const-expr-p tag)) (make-symbol "--cl-remf-tag--")))
1944           (val-temp (and (not (cl-simple-expr-p place))           (val-temp (and (not (cl-simple-expr-p place))
1945                          (gensym "--remf-place--")))                          (make-symbol "--cl-remf-place--")))
1946           (ttag (or tag-temp tag))           (ttag (or tag-temp tag))
1947           (tval (or val-temp (nth 2 method))))           (tval (or val-temp (nth 2 method))))
1948      (list 'let*      (list 'let*
# Line 1990  Each PLACE may be a symbol, or any gener Line 1984  Each PLACE may be a symbol, or any gener
1984                 (setq sets (nconc sets (list (pop args) (car args)))))                 (setq sets (nconc sets (list (pop args) (car args)))))
1985               (nconc (list 'psetf) sets (list (car args) first))))               (nconc (list 'psetf) sets (list (car args) first))))
1986      (let* ((places (reverse args))      (let* ((places (reverse args))
1987             (temp (gensym "--rotatef--"))             (temp (make-symbol "--cl-rotatef--"))
1988             (form temp))             (form temp))
1989        (while (cdr places)        (while (cdr places)
1990          (let ((method (cl-setf-do-modify (pop places) 'unsafe)))          (let ((method (cl-setf-do-modify (pop places) 'unsafe)))
# Line 2022  the PLACE is not modified before executi Line 2016  the PLACE is not modified before executi
2016                          (caar rev)))                          (caar rev)))
2017                 (value (cadar rev))                 (value (cadar rev))
2018                 (method (cl-setf-do-modify place 'no-opt))                 (method (cl-setf-do-modify place 'no-opt))
2019                 (save (gensym "--letf-save--"))                 (save (make-symbol "--cl-letf-save--"))
2020                 (bound (and (memq (car place) '(symbol-value symbol-function))                 (bound (and (memq (car place) '(symbol-value symbol-function))
2021                             (gensym "--letf-bound--")))                             (make-symbol "--cl-letf-bound--")))
2022                 (temp (and (not (cl-const-expr-p value)) (cdr bindings)                 (temp (and (not (cl-const-expr-p value)) (cdr bindings)
2023                            (gensym "--letf-val--"))))                            (make-symbol "--cl-letf-val--"))))
2024            (setq lets (nconc (car method)            (setq lets (nconc (car method)
2025                              (if bound                              (if bound
2026                                  (list (list bound                                  (list (list bound
# Line 2097  Like `callf', but PLACE is the second ar Line 2091  Like `callf', but PLACE is the second ar
2091    (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func))    (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func))
2092        (list 'setf place (list* func arg1 place args))        (list 'setf place (list* func arg1 place args))
2093      (let* ((method (cl-setf-do-modify place (cons 'list args)))      (let* ((method (cl-setf-do-modify place (cons 'list args)))
2094             (temp (and (not (cl-const-expr-p arg1)) (gensym "--arg1--")))             (temp (and (not (cl-const-expr-p arg1)) (make-symbol "--cl-arg1--")))
2095             (rargs (list* (or temp arg1) (nth 2 method) args)))             (rargs (list* (or temp arg1) (nth 2 method) args)))
2096        (list 'let* (append (and temp (list (list temp arg1))) (car method))        (list 'let* (append (and temp (list (list temp arg1))) (car method))
2097              (cl-setf-do-store (nth 1 method)              (cl-setf-do-store (nth 1 method)
# Line 2110  Like `callf', but PLACE is the second ar Line 2104  Like `callf', but PLACE is the second ar
2104  If NAME is called, it combines its PLACE argument with the other arguments  If NAME is called, it combines its PLACE argument with the other arguments
2105  from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)"  from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)"
2106    (if (memq '&key arglist) (error "&key not allowed in define-modify-macro"))    (if (memq '&key arglist) (error "&key not allowed in define-modify-macro"))
2107    (let ((place (gensym "--place--")))    (let ((place (make-symbol "--cl-place--")))
2108      (list 'defmacro* name (cons place arglist) doc      (list 'defmacro* name (cons place arglist) doc
2109            (list* (if (memq '&rest arglist) 'list* 'list)            (list* (if (memq '&rest arglist) 'list* 'list)
2110                   '(quote callf) (list 'quote func) place                   '(quote callf) (list 'quote func) place
# Line 2334  copier, a `NAME-p' predicate, and setf-a Line 2328  copier, a `NAME-p' predicate, and setf-a
2328      (cons 'progn (nreverse (cons (list 'quote name) forms)))))      (cons 'progn (nreverse (cons (list 'quote name) forms)))))
2329    
2330  (defun cl-struct-setf-expander (x name accessor pred-form pos)  (defun cl-struct-setf-expander (x name accessor pred-form pos)
2331    (let* ((temp (gensym "--x--")) (store (gensym "--store--")))    (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--")))
2332      (list (list temp) (list x) (list store)      (list (list temp) (list x) (list store)
2333            (append '(progn)            (append '(progn)
2334                    (and pred-form                    (and pred-form
# Line 2410  TYPE is a Common Lisp-style type specifi Line 2404  TYPE is a Common Lisp-style type specifi
2404  STRING is an optional description of the desired type."  STRING is an optional description of the desired type."
2405    (and (or (not (cl-compiling-file))    (and (or (not (cl-compiling-file))
2406             (< cl-optimize-speed 3) (= cl-optimize-safety 3))             (< cl-optimize-speed 3) (= cl-optimize-safety 3))
2407         (let* ((temp (if (cl-simple-expr-p form 3) form (gensym)))         (let* ((temp (if (cl-simple-expr-p form 3)
2408                            form (make-symbol "--cl-var--")))
2409                (body (list 'or (cl-make-type-test temp type)                (body (list 'or (cl-make-type-test temp type)
2410                            (list 'signal '(quote wrong-type-argument)                            (list 'signal '(quote wrong-type-argument)
2411                                  (list 'list (or string (list 'quote type))                                  (list 'list (or string (list 'quote type))
# Line 2607  surrounded by (block NAME ...). Line 2602  surrounded by (block NAME ...).
2602        (let ((res (cl-make-type-test val (cl-const-expr-val type))))        (let ((res (cl-make-type-test val (cl-const-expr-val type))))
2603          (if (or (memq (cl-expr-contains res val) '(nil 1))          (if (or (memq (cl-expr-contains res val) '(nil 1))
2604                  (cl-simple-expr-p val)) res                  (cl-simple-expr-p val)) res
2605            (let ((temp (gensym)))            (let ((temp (make-symbol "--cl-var--")))
2606              (list 'let (list (list temp val)) (subst temp val res)))))              (list 'let (list (list temp val)) (subst temp val res)))))
2607      form))      form))
2608    
2609    
2610  (mapcar (function  (mapc (lambda (y)
2611           (lambda (y)          (put (car y) 'side-effect-free t)
2612             (put (car y) 'side-effect-free t)          (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro)
2613             (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro)          (put (car y) 'cl-compiler-macro
2614             (put (car y) 'cl-compiler-macro               `(lambda (w x)
2615                  (list 'lambda '(w x)                  ,(if (symbolp (cadr y))
2616                        (if (symbolp (cadr y))                       `(list ',(cadr y)
2617                            (list 'list (list 'quote (cadr y))                              (list ',(caddr y) x))
2618                                  (list 'list (list 'quote (caddr y)) 'x))                     (cons 'list (cdr y))))))
2619                          (cons 'list (cdr y)))))))        '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x)
2620          '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x)          (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x)
2621            (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x)          (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x)
2622            (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x)          (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0)
2623            (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0)          (caaar car caar) (caadr car cadr) (cadar car cdar)
2624            (caaar car caar) (caadr car cadr) (cadar car cdar)          (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr)
2625            (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr)          (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar)
2626            (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar)          (caaadr car caadr) (caadar car cadar) (caaddr car caddr)
2627            (caaadr car caadr) (caadar car cadar) (caaddr car caddr)          (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar)
2628            (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar)          (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr)
2629            (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr)          (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar)
2630            (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar)          (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) ))
           (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) ))  
2631    
2632  ;;; Things that are inline.  ;;; Things that are inline.
2633  (proclaim '(inline floatp-safe acons map concatenate notany notevery  (proclaim '(inline floatp-safe acons map concatenate notany notevery
2634                     cl-set-elt revappend nreconc gethash))                     cl-set-elt revappend nreconc gethash))
2635    
2636  ;;; Things that are side-effect-free.  ;;; Things that are side-effect-free.
2637  (mapcar (function (lambda (x) (put x 'side-effect-free t)))  (mapc (lambda (x) (put x 'side-effect-free t))
2638          '(oddp evenp signum last butlast ldiff pairlis gcd lcm        '(oddp evenp signum last butlast ldiff pairlis gcd lcm
2639            isqrt floor* ceiling* truncate* round* mod* rem* subseq          isqrt floor* ceiling* truncate* round* mod* rem* subseq
2640            list-length get* getf))          list-length get* getf))
2641    
2642  ;;; Things that are side-effect-and-error-free.  ;;; Things that are side-effect-and-error-free.
2643  (mapcar (function (lambda (x) (put x 'side-effect-free 'error-free)))  (mapc (lambda (x) (put x 'side-effect-free 'error-free))
2644          '(eql floatp-safe list* subst acons equalp random-state-p        '(eql floatp-safe list* subst acons equalp random-state-p
2645            copy-tree sublis))          copy-tree sublis))
2646    
2647    
2648  (run-hooks 'cl-macs-load-hook)  (run-hooks 'cl-macs-load-hook)
# Line 2657  surrounded by (block NAME ...). Line 2651  surrounded by (block NAME ...).
2651  ;;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete noruntime)  ;;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete noruntime)
2652  ;;; End:  ;;; End:
2653    
2654  ;;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46  ;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46
2655  ;;; cl-macs.el ends here  ;;; cl-macs.el ends here

Legend:
Removed from v.1.34.4.4  
changed lines
  Added in v.1.34.4.5

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26