Mercurial > emacs
comparison lisp/emacs-lisp/cl-macs.el @ 58255:65bbc782c81c
Use make-symbol rather than gensym.
(loop, cl-parse-loop-clause, defsetf): Use backquote.
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Tue, 16 Nov 2004 04:05:29 +0000 |
parents | a0ba84563db6 |
children | 24b04ef917a7 b637c617432f |
comparison
equal
deleted
inserted
replaced
58254:e64002f85cf6 | 58255:65bbc782c81c |
---|---|
290 (safety (if (cl-compiling-file) cl-optimize-safety 3)) | 290 (safety (if (cl-compiling-file) cl-optimize-safety 3)) |
291 (keys nil) | 291 (keys nil) |
292 (laterarg nil) (exactarg nil) minarg) | 292 (laterarg nil) (exactarg nil) minarg) |
293 (or num (setq num 0)) | 293 (or num (setq num 0)) |
294 (if (listp (cadr restarg)) | 294 (if (listp (cadr restarg)) |
295 (setq restarg (gensym "--rest--")) | 295 (setq restarg (make-symbol "--cl-rest--")) |
296 (setq restarg (cadr restarg))) | 296 (setq restarg (cadr restarg))) |
297 (push (list restarg expr) bind-lets) | 297 (push (list restarg expr) bind-lets) |
298 (if (eq (car args) '&whole) | 298 (if (eq (car args) '&whole) |
299 (push (list (cl-pop2 args) restarg) bind-lets)) | 299 (push (list (cl-pop2 args) restarg) bind-lets)) |
300 (let ((p args)) | 300 (let ((p args)) |
352 (def (if (cdr arg) (cadr arg) | 352 (def (if (cdr arg) (cadr arg) |
353 (or (car bind-defs) (cadr (assq varg bind-defs))))) | 353 (or (car bind-defs) (cadr (assq varg bind-defs))))) |
354 (look (list 'memq (list 'quote karg) restarg))) | 354 (look (list 'memq (list 'quote karg) restarg))) |
355 (and def bind-enquote (setq def (list 'quote def))) | 355 (and def bind-enquote (setq def (list 'quote def))) |
356 (if (cddr arg) | 356 (if (cddr arg) |
357 (let* ((temp (or (nth 2 arg) (gensym))) | 357 (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--"))) |
358 (val (list 'car (list 'cdr temp)))) | 358 (val (list 'car (list 'cdr temp)))) |
359 (cl-do-arglist temp look) | 359 (cl-do-arglist temp look) |
360 (cl-do-arglist varg | 360 (cl-do-arglist varg |
361 (list 'if temp | 361 (list 'if temp |
362 (list 'prog1 val (list 'setq temp t)) | 362 (list 'prog1 val (list 'setq temp t)) |
375 (list 'list nil def)))))))) | 375 (list 'list nil def)))))))) |
376 (push karg keys))))) | 376 (push karg keys))))) |
377 (setq keys (nreverse keys)) | 377 (setq keys (nreverse keys)) |
378 (or (and (eq (car args) '&allow-other-keys) (pop args)) | 378 (or (and (eq (car args) '&allow-other-keys) (pop args)) |
379 (null keys) (= safety 0) | 379 (null keys) (= safety 0) |
380 (let* ((var (gensym "--keys--")) | 380 (let* ((var (make-symbol "--cl-keys--")) |
381 (allow '(:allow-other-keys)) | 381 (allow '(:allow-other-keys)) |
382 (check (list | 382 (check (list |
383 'while var | 383 'while var |
384 (list | 384 (list |
385 'cond | 385 'cond |
492 against each key in each KEYLIST; the corresponding BODY is evaluated. | 492 against each key in each KEYLIST; the corresponding BODY is evaluated. |
493 If no clause succeeds, case returns nil. A single atom may be used in | 493 If no clause succeeds, case returns nil. A single atom may be used in |
494 place of a KEYLIST of one atom. A KEYLIST of t or `otherwise' is | 494 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. | 495 allowed only in the final clause, and matches if no other keys match. |
496 Key values are compared by `eql'." | 496 Key values are compared by `eql'." |
497 (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym))) | 497 (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) |
498 (head-list nil) | 498 (head-list nil) |
499 (body (cons | 499 (body (cons |
500 'cond | 500 'cond |
501 (mapcar | 501 (mapcar |
502 (function | 502 (function |
528 "Evals EXPR, chooses from CLAUSES on that value. | 528 "Evals EXPR, chooses from CLAUSES on that value. |
529 Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it | 529 Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it |
530 satisfies TYPE, the corresponding BODY is evaluated. If no clause succeeds, | 530 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 | 531 typecase returns nil. A TYPE of t or `otherwise' is allowed only in the |
532 final clause, and matches if no other keys match." | 532 final clause, and matches if no other keys match." |
533 (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym))) | 533 (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) |
534 (type-list nil) | 534 (type-list nil) |
535 (body (cons | 535 (body (cons |
536 'cond | 536 'cond |
537 (mapcar | 537 (mapcar |
538 (function | 538 (function |
642 (loop-map-form nil) (loop-first-flag nil) | 642 (loop-map-form nil) (loop-first-flag nil) |
643 (loop-destr-temps nil) (loop-symbol-macs nil)) | 643 (loop-destr-temps nil) (loop-symbol-macs nil)) |
644 (setq args (append args '(cl-end-loop))) | 644 (setq args (append args '(cl-end-loop))) |
645 (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause)) | 645 (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause)) |
646 (if loop-finish-flag | 646 (if loop-finish-flag |
647 (push (list (list loop-finish-flag t)) loop-bindings)) | 647 (push `((,loop-finish-flag t)) loop-bindings)) |
648 (if loop-first-flag | 648 (if loop-first-flag |
649 (progn (push (list (list loop-first-flag t)) loop-bindings) | 649 (progn (push `((,loop-first-flag t)) loop-bindings) |
650 (push (list 'setq loop-first-flag nil) loop-steps))) | 650 (push `(setq ,loop-first-flag nil) loop-steps))) |
651 (let* ((epilogue (nconc (nreverse loop-finally) | 651 (let* ((epilogue (nconc (nreverse loop-finally) |
652 (list (or loop-result-explicit loop-result)))) | 652 (list (or loop-result-explicit loop-result)))) |
653 (ands (cl-loop-build-ands (nreverse loop-body))) | 653 (ands (cl-loop-build-ands (nreverse loop-body))) |
654 (while-body (nconc (cadr ands) (nreverse loop-steps))) | 654 (while-body (nconc (cadr ands) (nreverse loop-steps))) |
655 (body (append | 655 (body (append |
656 (nreverse loop-initially) | 656 (nreverse loop-initially) |
657 (list (if loop-map-form | 657 (list (if loop-map-form |
658 (list 'block '--cl-finish-- | 658 (list 'block '--cl-finish-- |
659 (subst | 659 (subst |
660 (if (eq (car ands) t) while-body | 660 (if (eq (car ands) t) while-body |
661 (cons (list 'or (car ands) | 661 (cons `(or ,(car ands) |
662 '(return-from --cl-finish-- | 662 (return-from --cl-finish-- |
663 nil)) | 663 nil)) |
664 while-body)) | 664 while-body)) |
665 '--cl-map loop-map-form)) | 665 '--cl-map loop-map-form)) |
666 (list* 'while (car ands) while-body))) | 666 (list* 'while (car ands) while-body))) |
667 (if loop-finish-flag | 667 (if loop-finish-flag |
668 (if (equal epilogue '(nil)) (list loop-result-var) | 668 (if (equal epilogue '(nil)) (list loop-result-var) |
669 (list (list 'if loop-finish-flag | 669 `((if ,loop-finish-flag |
670 (cons 'progn epilogue) loop-result-var))) | 670 (progn ,@epilogue) ,loop-result-var))) |
671 epilogue)))) | 671 epilogue)))) |
672 (if loop-result-var (push (list loop-result-var) loop-bindings)) | 672 (if loop-result-var (push (list loop-result-var) loop-bindings)) |
673 (while loop-bindings | 673 (while loop-bindings |
674 (if (cdar loop-bindings) | 674 (if (cdar loop-bindings) |
675 (setq body (list (cl-loop-let (pop loop-bindings) body t))) | 675 (setq body (list (cl-loop-let (pop loop-bindings) body t))) |
680 (setq body (list (cl-loop-let lets body nil)))))) | 680 (setq body (list (cl-loop-let lets body nil)))))) |
681 (if loop-symbol-macs | 681 (if loop-symbol-macs |
682 (setq body (list (list* 'symbol-macrolet loop-symbol-macs body)))) | 682 (setq body (list (list* 'symbol-macrolet loop-symbol-macs body)))) |
683 (list* 'block loop-name body))))) | 683 (list* 'block loop-name body))))) |
684 | 684 |
685 (defun cl-parse-loop-clause () ; uses args, loop-* | 685 (defun cl-parse-loop-clause () ; uses args, loop-* |
686 (let ((word (pop args)) | 686 (let ((word (pop args)) |
687 (hash-types '(hash-key hash-keys hash-value hash-values)) | 687 (hash-types '(hash-key hash-keys hash-value hash-values)) |
688 (key-types '(key-code key-codes key-seq key-seqs | 688 (key-types '(key-code key-codes key-seq key-seqs |
689 key-binding key-bindings))) | 689 key-binding key-bindings))) |
690 (cond | 690 (cond |
713 | 713 |
714 ((memq word '(for as)) | 714 ((memq word '(for as)) |
715 (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) | 715 (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) |
716 (ands nil)) | 716 (ands nil)) |
717 (while | 717 (while |
718 (let ((var (or (pop args) (gensym)))) | 718 (let ((var (or (pop args) (make-symbol "--cl-var--")))) |
719 (setq word (pop args)) | 719 (setq word (pop args)) |
720 (if (eq word 'being) (setq word (pop args))) | 720 (if (eq word 'being) (setq word (pop args))) |
721 (if (memq word '(the each)) (setq word (pop args))) | 721 (if (memq word '(the each)) (setq word (pop args))) |
722 (if (memq word '(buffer buffers)) | 722 (if (memq word '(buffer buffers)) |
723 (setq word 'in args (cons '(buffer-list) args))) | 723 (setq word 'in args (cons '(buffer-list) args))) |
736 (cl-pop2 args))) | 736 (cl-pop2 args))) |
737 (end (and (memq (car args) | 737 (end (and (memq (car args) |
738 '(to upto downto above below)) | 738 '(to upto downto above below)) |
739 (cl-pop2 args))) | 739 (cl-pop2 args))) |
740 (step (and (eq (car args) 'by) (cl-pop2 args))) | 740 (step (and (eq (car args) 'by) (cl-pop2 args))) |
741 (end-var (and (not (cl-const-expr-p end)) (gensym))) | 741 (end-var (and (not (cl-const-expr-p end)) |
742 (make-symbol "--cl-var--"))) | |
742 (step-var (and (not (cl-const-expr-p step)) | 743 (step-var (and (not (cl-const-expr-p step)) |
743 (gensym)))) | 744 (make-symbol "--cl-var--")))) |
744 (and step (numberp step) (<= step 0) | 745 (and step (numberp step) (<= step 0) |
745 (error "Loop `by' value is not positive: %s" step)) | 746 (error "Loop `by' value is not positive: %s" step)) |
746 (push (list var (or start 0)) loop-for-bindings) | 747 (push (list var (or start 0)) loop-for-bindings) |
747 (if end-var (push (list end-var end) loop-for-bindings)) | 748 (if end-var (push (list end-var end) loop-for-bindings)) |
748 (if step-var (push (list step-var step) | 749 (if step-var (push (list step-var step) |
749 loop-for-bindings)) | 750 loop-for-bindings)) |
750 (if end | 751 (if end |
751 (push (list | 752 (push (list |
752 (if down (if excl '> '>=) (if excl '< '<=)) | 753 (if down (if excl '> '>=) (if excl '< '<=)) |
753 var (or end-var end)) loop-body)) | 754 var (or end-var end)) loop-body)) |
754 (push (list var (list (if down '- '+) var | 755 (push (list var (list (if down '- '+) var |
755 (or step-var step 1))) | 756 (or step-var step 1))) |
756 loop-for-steps))) | 757 loop-for-steps))) |
757 | 758 |
758 ((memq word '(in in-ref on)) | 759 ((memq word '(in in-ref on)) |
759 (let* ((on (eq word 'on)) | 760 (let* ((on (eq word 'on)) |
760 (temp (if (and on (symbolp var)) var (gensym)))) | 761 (temp (if (and on (symbolp var)) |
762 var (make-symbol "--cl-var--")))) | |
761 (push (list temp (pop args)) loop-for-bindings) | 763 (push (list temp (pop args)) loop-for-bindings) |
762 (push (list 'consp temp) loop-body) | 764 (push (list 'consp temp) loop-body) |
763 (if (eq word 'in-ref) | 765 (if (eq word 'in-ref) |
764 (push (list var (list 'car temp)) loop-symbol-macs) | 766 (push (list var (list 'car temp)) loop-symbol-macs) |
765 (or (eq temp var) | 767 (or (eq temp var) |
766 (progn | 768 (progn |
767 (push (list var nil) loop-for-bindings) | 769 (push (list var nil) loop-for-bindings) |
768 (push (list var (if on temp (list 'car temp))) | 770 (push (list var (if on temp (list 'car temp))) |
769 loop-for-sets)))) | 771 loop-for-sets)))) |
770 (push (list temp | 772 (push (list temp |
771 (if (eq (car args) 'by) | 773 (if (eq (car args) 'by) |
772 (let ((step (cl-pop2 args))) | 774 (let ((step (cl-pop2 args))) |
773 (if (and (memq (car-safe step) | 775 (if (and (memq (car-safe step) |
774 '(quote function | 776 '(quote function |
775 function*)) | 777 function*)) |
776 (symbolp (nth 1 step))) | 778 (symbolp (nth 1 step))) |
777 (list (nth 1 step) temp) | 779 (list (nth 1 step) temp) |
778 (list 'funcall step temp))) | 780 (list 'funcall step temp))) |
779 (list 'cdr temp))) | 781 (list 'cdr temp))) |
780 loop-for-steps))) | 782 loop-for-steps))) |
781 | 783 |
782 ((eq word '=) | 784 ((eq word '=) |
783 (let* ((start (pop args)) | 785 (let* ((start (pop args)) |
784 (then (if (eq (car args) 'then) (cl-pop2 args) start))) | 786 (then (if (eq (car args) 'then) (cl-pop2 args) start))) |
785 (push (list var nil) loop-for-bindings) | 787 (push (list var nil) loop-for-bindings) |
786 (if (or ands (eq (car args) 'and)) | 788 (if (or ands (eq (car args) 'and)) |
787 (progn | 789 (progn |
788 (push (list var | 790 (push `(,var |
789 (list 'if | 791 (if ,(or loop-first-flag |
790 (or loop-first-flag | 792 (setq loop-first-flag |
791 (setq loop-first-flag | 793 (make-symbol "--cl-var--"))) |
792 (gensym))) | 794 ,start ,var)) |
793 start var)) | 795 loop-for-sets) |
794 loop-for-sets) | |
795 (push (list var then) loop-for-steps)) | 796 (push (list var then) loop-for-steps)) |
796 (push (list var | 797 (push (list var |
797 (if (eq start then) start | 798 (if (eq start then) start |
798 (list 'if | 799 `(if ,(or loop-first-flag |
799 (or loop-first-flag | 800 (setq loop-first-flag |
800 (setq loop-first-flag (gensym))) | 801 (make-symbol "--cl-var--"))) |
801 start then))) | 802 ,start ,then))) |
802 loop-for-sets)))) | 803 loop-for-sets)))) |
803 | 804 |
804 ((memq word '(across across-ref)) | 805 ((memq word '(across across-ref)) |
805 (let ((temp-vec (gensym)) (temp-idx (gensym))) | 806 (let ((temp-vec (make-symbol "--cl-vec--")) |
807 (temp-idx (make-symbol "--cl-idx--"))) | |
806 (push (list temp-vec (pop args)) loop-for-bindings) | 808 (push (list temp-vec (pop args)) loop-for-bindings) |
807 (push (list temp-idx -1) loop-for-bindings) | 809 (push (list temp-idx -1) loop-for-bindings) |
808 (push (list '< (list 'setq temp-idx (list '1+ temp-idx)) | 810 (push (list '< (list 'setq temp-idx (list '1+ temp-idx)) |
809 (list 'length temp-vec)) loop-body) | 811 (list 'length temp-vec)) loop-body) |
810 (if (eq word 'across-ref) | 812 (if (eq word 'across-ref) |
811 (push (list var (list 'aref temp-vec temp-idx)) | 813 (push (list var (list 'aref temp-vec temp-idx)) |
812 loop-symbol-macs) | 814 loop-symbol-macs) |
813 (push (list var nil) loop-for-bindings) | 815 (push (list var nil) loop-for-bindings) |
814 (push (list var (list 'aref temp-vec temp-idx)) | 816 (push (list var (list 'aref temp-vec temp-idx)) |
815 loop-for-sets)))) | 817 loop-for-sets)))) |
816 | 818 |
817 ((memq word '(element elements)) | 819 ((memq word '(element elements)) |
818 (let ((ref (or (memq (car args) '(in-ref of-ref)) | 820 (let ((ref (or (memq (car args) '(in-ref of-ref)) |
819 (and (not (memq (car args) '(in of))) | 821 (and (not (memq (car args) '(in of))) |
820 (error "Expected `of'")))) | 822 (error "Expected `of'")))) |
821 (seq (cl-pop2 args)) | 823 (seq (cl-pop2 args)) |
822 (temp-seq (gensym)) | 824 (temp-seq (make-symbol "--cl-seq--")) |
823 (temp-idx (if (eq (car args) 'using) | 825 (temp-idx (if (eq (car args) 'using) |
824 (if (and (= (length (cadr args)) 2) | 826 (if (and (= (length (cadr args)) 2) |
825 (eq (caadr args) 'index)) | 827 (eq (caadr args) 'index)) |
826 (cadr (cl-pop2 args)) | 828 (cadr (cl-pop2 args)) |
827 (error "Bad `using' clause")) | 829 (error "Bad `using' clause")) |
828 (gensym)))) | 830 (make-symbol "--cl-idx--")))) |
829 (push (list temp-seq seq) loop-for-bindings) | 831 (push (list temp-seq seq) loop-for-bindings) |
830 (push (list temp-idx 0) loop-for-bindings) | 832 (push (list temp-idx 0) loop-for-bindings) |
831 (if ref | 833 (if ref |
832 (let ((temp-len (gensym))) | 834 (let ((temp-len (make-symbol "--cl-len--"))) |
833 (push (list temp-len (list 'length temp-seq)) | 835 (push (list temp-len (list 'length temp-seq)) |
834 loop-for-bindings) | 836 loop-for-bindings) |
835 (push (list var (list 'elt temp-seq temp-idx)) | 837 (push (list var (list 'elt temp-seq temp-idx)) |
836 loop-symbol-macs) | 838 loop-symbol-macs) |
837 (push (list '< temp-idx temp-len) loop-body)) | 839 (push (list '< temp-idx temp-len) loop-body)) |
838 (push (list var nil) loop-for-bindings) | 840 (push (list var nil) loop-for-bindings) |
839 (push (list 'and temp-seq | 841 (push (list 'and temp-seq |
840 (list 'or (list 'consp temp-seq) | 842 (list 'or (list 'consp temp-seq) |
841 (list '< temp-idx | 843 (list '< temp-idx |
842 (list 'length temp-seq)))) | 844 (list 'length temp-seq)))) |
843 loop-body) | 845 loop-body) |
844 (push (list var (list 'if (list 'consp temp-seq) | 846 (push (list var (list 'if (list 'consp temp-seq) |
845 (list 'pop temp-seq) | 847 (list 'pop temp-seq) |
846 (list 'aref temp-seq temp-idx))) | 848 (list 'aref temp-seq temp-idx))) |
847 loop-for-sets)) | 849 loop-for-sets)) |
848 (push (list temp-idx (list '1+ temp-idx)) | 850 (push (list temp-idx (list '1+ temp-idx)) |
849 loop-for-steps))) | 851 loop-for-steps))) |
850 | 852 |
851 ((memq word hash-types) | 853 ((memq word hash-types) |
852 (or (memq (car args) '(in of)) (error "Expected `of'")) | 854 (or (memq (car args) '(in of)) (error "Expected `of'")) |
853 (let* ((table (cl-pop2 args)) | 855 (let* ((table (cl-pop2 args)) |
854 (other (if (eq (car args) 'using) | 856 (other (if (eq (car args) 'using) |
855 (if (and (= (length (cadr args)) 2) | 857 (if (and (= (length (cadr args)) 2) |
856 (memq (caadr args) hash-types) | 858 (memq (caadr args) hash-types) |
857 (not (eq (caadr args) word))) | 859 (not (eq (caadr args) word))) |
858 (cadr (cl-pop2 args)) | 860 (cadr (cl-pop2 args)) |
859 (error "Bad `using' clause")) | 861 (error "Bad `using' clause")) |
860 (gensym)))) | 862 (make-symbol "--cl-var--")))) |
861 (if (memq word '(hash-value hash-values)) | 863 (if (memq word '(hash-value hash-values)) |
862 (setq var (prog1 other (setq other var)))) | 864 (setq var (prog1 other (setq other var)))) |
863 (setq loop-map-form | 865 (setq loop-map-form |
864 (list 'maphash (list 'function | 866 `(maphash (lambda (,var ,other) . --cl-map) ,table)))) |
865 (list* 'lambda (list var other) | |
866 '--cl-map)) table)))) | |
867 | 867 |
868 ((memq word '(symbol present-symbol external-symbol | 868 ((memq word '(symbol present-symbol external-symbol |
869 symbols present-symbols external-symbols)) | 869 symbols present-symbols external-symbols)) |
870 (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args)))) | 870 (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args)))) |
871 (setq loop-map-form | 871 (setq loop-map-form |
872 (list 'mapatoms (list 'function | 872 `(mapatoms (lambda (,var) . --cl-map) ,ob)))) |
873 (list* 'lambda (list var) | |
874 '--cl-map)) ob)))) | |
875 | 873 |
876 ((memq word '(overlay overlays extent extents)) | 874 ((memq word '(overlay overlays extent extents)) |
877 (let ((buf nil) (from nil) (to nil)) | 875 (let ((buf nil) (from nil) (to nil)) |
878 (while (memq (car args) '(in of from to)) | 876 (while (memq (car args) '(in of from to)) |
879 (cond ((eq (car args) 'from) (setq from (cl-pop2 args))) | 877 (cond ((eq (car args) 'from) (setq from (cl-pop2 args))) |
880 ((eq (car args) 'to) (setq to (cl-pop2 args))) | 878 ((eq (car args) 'to) (setq to (cl-pop2 args))) |
881 (t (setq buf (cl-pop2 args))))) | 879 (t (setq buf (cl-pop2 args))))) |
882 (setq loop-map-form | 880 (setq loop-map-form |
883 (list 'cl-map-extents | 881 `(cl-map-extents |
884 (list 'function (list 'lambda (list var (gensym)) | 882 (lambda (,var ,(make-symbol "--cl-var--")) |
885 '(progn . --cl-map) nil)) | 883 (progn . --cl-map) nil) |
886 buf from to)))) | 884 ,buf ,from ,to)))) |
887 | 885 |
888 ((memq word '(interval intervals)) | 886 ((memq word '(interval intervals)) |
889 (let ((buf nil) (prop nil) (from nil) (to nil) | 887 (let ((buf nil) (prop nil) (from nil) (to nil) |
890 (var1 (gensym)) (var2 (gensym))) | 888 (var1 (make-symbol "--cl-var1--")) |
889 (var2 (make-symbol "--cl-var2--"))) | |
891 (while (memq (car args) '(in of property from to)) | 890 (while (memq (car args) '(in of property from to)) |
892 (cond ((eq (car args) 'from) (setq from (cl-pop2 args))) | 891 (cond ((eq (car args) 'from) (setq from (cl-pop2 args))) |
893 ((eq (car args) 'to) (setq to (cl-pop2 args))) | 892 ((eq (car args) 'to) (setq to (cl-pop2 args))) |
894 ((eq (car args) 'property) | 893 ((eq (car args) 'property) |
895 (setq prop (cl-pop2 args))) | 894 (setq prop (cl-pop2 args))) |
896 (t (setq buf (cl-pop2 args))))) | 895 (t (setq buf (cl-pop2 args))))) |
897 (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) | 896 (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) |
898 (setq var1 (car var) var2 (cdr var)) | 897 (setq var1 (car var) var2 (cdr var)) |
899 (push (list var (list 'cons var1 var2)) loop-for-sets)) | 898 (push (list var (list 'cons var1 var2)) loop-for-sets)) |
900 (setq loop-map-form | 899 (setq loop-map-form |
901 (list 'cl-map-intervals | 900 `(cl-map-intervals |
902 (list 'function (list 'lambda (list var1 var2) | 901 (lambda (,var1 ,var2) . --cl-map) |
903 '(progn . --cl-map))) | 902 ,buf ,prop ,from ,to)))) |
904 buf prop from to)))) | |
905 | 903 |
906 ((memq word key-types) | 904 ((memq word key-types) |
907 (or (memq (car args) '(in of)) (error "Expected `of'")) | 905 (or (memq (car args) '(in of)) (error "Expected `of'")) |
908 (let ((map (cl-pop2 args)) | 906 (let ((map (cl-pop2 args)) |
909 (other (if (eq (car args) 'using) | 907 (other (if (eq (car args) 'using) |
910 (if (and (= (length (cadr args)) 2) | 908 (if (and (= (length (cadr args)) 2) |
911 (memq (caadr args) key-types) | 909 (memq (caadr args) key-types) |
912 (not (eq (caadr args) word))) | 910 (not (eq (caadr args) word))) |
913 (cadr (cl-pop2 args)) | 911 (cadr (cl-pop2 args)) |
914 (error "Bad `using' clause")) | 912 (error "Bad `using' clause")) |
915 (gensym)))) | 913 (make-symbol "--cl-var--")))) |
916 (if (memq word '(key-binding key-bindings)) | 914 (if (memq word '(key-binding key-bindings)) |
917 (setq var (prog1 other (setq other var)))) | 915 (setq var (prog1 other (setq other var)))) |
918 (setq loop-map-form | 916 (setq loop-map-form |
919 (list (if (memq word '(key-seq key-seqs)) | 917 `(,(if (memq word '(key-seq key-seqs)) |
920 'cl-map-keymap-recursively 'map-keymap) | 918 'cl-map-keymap-recursively 'map-keymap) |
921 (list 'function (list* 'lambda (list var other) | 919 (lambda (,var ,other) . --cl-map) ,map)))) |
922 '--cl-map)) map)))) | |
923 | 920 |
924 ((memq word '(frame frames screen screens)) | 921 ((memq word '(frame frames screen screens)) |
925 (let ((temp (gensym))) | 922 (let ((temp (make-symbol "--cl-var--"))) |
926 (push (list var '(selected-frame)) | 923 (push (list var '(selected-frame)) |
927 loop-for-bindings) | 924 loop-for-bindings) |
928 (push (list temp nil) loop-for-bindings) | 925 (push (list temp nil) loop-for-bindings) |
929 (push (list 'prog1 (list 'not (list 'eq var temp)) | 926 (push (list 'prog1 (list 'not (list 'eq var temp)) |
930 (list 'or temp (list 'setq temp var))) | 927 (list 'or temp (list 'setq temp var))) |
931 loop-body) | 928 loop-body) |
932 (push (list var (list 'next-frame var)) | 929 (push (list var (list 'next-frame var)) |
933 loop-for-steps))) | 930 loop-for-steps))) |
934 | 931 |
935 ((memq word '(window windows)) | 932 ((memq word '(window windows)) |
936 (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args))) | 933 (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args))) |
937 (temp (gensym))) | 934 (temp (make-symbol "--cl-var--"))) |
938 (push (list var (if scr | 935 (push (list var (if scr |
939 (list 'frame-selected-window scr) | 936 (list 'frame-selected-window scr) |
940 '(selected-window))) | 937 '(selected-window))) |
941 loop-for-bindings) | 938 loop-for-bindings) |
942 (push (list temp nil) loop-for-bindings) | 939 (push (list temp nil) loop-for-bindings) |
943 (push (list 'prog1 (list 'not (list 'eq var temp)) | 940 (push (list 'prog1 (list 'not (list 'eq var temp)) |
944 (list 'or temp (list 'setq temp var))) | 941 (list 'or temp (list 'setq temp var))) |
945 loop-body) | 942 loop-body) |
946 (push (list var (list 'next-window var)) loop-for-steps))) | 943 (push (list var (list 'next-window var)) loop-for-steps))) |
947 | 944 |
948 (t | 945 (t |
949 (let ((handler (and (symbolp word) | 946 (let ((handler (and (symbolp word) |
950 (get word 'cl-loop-for-handler)))) | 947 (get word 'cl-loop-for-handler)))) |
958 (push (nreverse loop-for-bindings) loop-bindings) | 955 (push (nreverse loop-for-bindings) loop-bindings) |
959 (setq loop-bindings (nconc (mapcar 'list loop-for-bindings) | 956 (setq loop-bindings (nconc (mapcar 'list loop-for-bindings) |
960 loop-bindings))) | 957 loop-bindings))) |
961 (if loop-for-sets | 958 (if loop-for-sets |
962 (push (list 'progn | 959 (push (list 'progn |
963 (cl-loop-let (nreverse loop-for-sets) 'setq ands) | 960 (cl-loop-let (nreverse loop-for-sets) 'setq ands) |
964 t) loop-body)) | 961 t) loop-body)) |
965 (if loop-for-steps | 962 (if loop-for-steps |
966 (push (cons (if ands 'psetq 'setq) | 963 (push (cons (if ands 'psetq 'setq) |
967 (apply 'append (nreverse loop-for-steps))) | 964 (apply 'append (nreverse loop-for-steps))) |
968 loop-steps)))) | 965 loop-steps)))) |
969 | 966 |
970 ((eq word 'repeat) | 967 ((eq word 'repeat) |
971 (let ((temp (gensym))) | 968 (let ((temp (make-symbol "--cl-var--"))) |
972 (push (list (list temp (pop args))) loop-bindings) | 969 (push (list (list temp (pop args))) loop-bindings) |
973 (push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body))) | 970 (push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body))) |
974 | 971 |
975 ((memq word '(collect collecting)) | 972 ((memq word '(collect collecting)) |
976 (let ((what (pop args)) | 973 (let ((what (pop args)) |
977 (var (cl-loop-handle-accum nil 'nreverse))) | 974 (var (cl-loop-handle-accum nil 'nreverse))) |
978 (if (eq var loop-accum-var) | 975 (if (eq var loop-accum-var) |
979 (push (list 'progn (list 'push what var) t) loop-body) | 976 (push (list 'progn (list 'push what var) t) loop-body) |
980 (push (list 'progn | 977 (push (list 'progn |
981 (list 'setq var (list 'nconc var (list 'list what))) | 978 (list 'setq var (list 'nconc var (list 'list what))) |
982 t) loop-body)))) | 979 t) loop-body)))) |
983 | 980 |
984 ((memq word '(nconc nconcing append appending)) | 981 ((memq word '(nconc nconcing append appending)) |
985 (let ((what (pop args)) | 982 (let ((what (pop args)) |
986 (var (cl-loop-handle-accum nil 'nreverse))) | 983 (var (cl-loop-handle-accum nil 'nreverse))) |
987 (push (list 'progn | 984 (push (list 'progn |
988 (list 'setq var | 985 (list 'setq var |
989 (if (eq var loop-accum-var) | 986 (if (eq var loop-accum-var) |
990 (list 'nconc | 987 (list 'nconc |
991 (list (if (memq word '(nconc nconcing)) | 988 (list (if (memq word '(nconc nconcing)) |
992 'nreverse 'reverse) | 989 'nreverse 'reverse) |
993 what) | 990 what) |
994 var) | 991 var) |
995 (list (if (memq word '(nconc nconcing)) | 992 (list (if (memq word '(nconc nconcing)) |
996 'nconc 'append) | 993 'nconc 'append) |
997 var what))) t) loop-body))) | 994 var what))) t) loop-body))) |
998 | 995 |
999 ((memq word '(concat concating)) | 996 ((memq word '(concat concating)) |
1000 (let ((what (pop args)) | 997 (let ((what (pop args)) |
1001 (var (cl-loop-handle-accum ""))) | 998 (var (cl-loop-handle-accum ""))) |
1002 (push (list 'progn (list 'callf 'concat var what) t) loop-body))) | 999 (push (list 'progn (list 'callf 'concat var what) t) loop-body))) |
1016 (var (cl-loop-handle-accum 0))) | 1013 (var (cl-loop-handle-accum 0))) |
1017 (push (list 'progn (list 'if what (list 'incf var)) t) loop-body))) | 1014 (push (list 'progn (list 'if what (list 'incf var)) t) loop-body))) |
1018 | 1015 |
1019 ((memq word '(minimize minimizing maximize maximizing)) | 1016 ((memq word '(minimize minimizing maximize maximizing)) |
1020 (let* ((what (pop args)) | 1017 (let* ((what (pop args)) |
1021 (temp (if (cl-simple-expr-p what) what (gensym))) | 1018 (temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--"))) |
1022 (var (cl-loop-handle-accum nil)) | 1019 (var (cl-loop-handle-accum nil)) |
1023 (func (intern (substring (symbol-name word) 0 3))) | 1020 (func (intern (substring (symbol-name word) 0 3))) |
1024 (set (list 'setq var (list 'if var (list func var temp) temp)))) | 1021 (set (list 'setq var (list 'if var (list func var temp) temp)))) |
1025 (push (list 'progn (if (eq temp what) set | 1022 (push (list 'progn (if (eq temp what) set |
1026 (list 'let (list (list temp what)) set)) | 1023 (list 'let (list (list temp what)) set)) |
1027 t) loop-body))) | 1024 t) loop-body))) |
1028 | 1025 |
1029 ((eq word 'with) | 1026 ((eq word 'with) |
1030 (let ((bindings nil)) | 1027 (let ((bindings nil)) |
1031 (while (progn (push (list (pop args) | 1028 (while (progn (push (list (pop args) |
1032 (and (eq (car args) '=) (cl-pop2 args))) | 1029 (and (eq (car args) '=) (cl-pop2 args))) |
1033 bindings) | 1030 bindings) |
1034 (eq (car args) 'and)) | 1031 (eq (car args) 'and)) |
1035 (pop args)) | 1032 (pop args)) |
1036 (push (nreverse bindings) loop-bindings))) | 1033 (push (nreverse bindings) loop-bindings))) |
1037 | 1034 |
1038 ((eq word 'while) | 1035 ((eq word 'while) |
1040 | 1037 |
1041 ((eq word 'until) | 1038 ((eq word 'until) |
1042 (push (list 'not (pop args)) loop-body)) | 1039 (push (list 'not (pop args)) loop-body)) |
1043 | 1040 |
1044 ((eq word 'always) | 1041 ((eq word 'always) |
1045 (or loop-finish-flag (setq loop-finish-flag (gensym))) | 1042 (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) |
1046 (push (list 'setq loop-finish-flag (pop args)) loop-body) | 1043 (push (list 'setq loop-finish-flag (pop args)) loop-body) |
1047 (setq loop-result t)) | 1044 (setq loop-result t)) |
1048 | 1045 |
1049 ((eq word 'never) | 1046 ((eq word 'never) |
1050 (or loop-finish-flag (setq loop-finish-flag (gensym))) | 1047 (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) |
1051 (push (list 'setq loop-finish-flag (list 'not (pop args))) | 1048 (push (list 'setq loop-finish-flag (list 'not (pop args))) |
1052 loop-body) | 1049 loop-body) |
1053 (setq loop-result t)) | 1050 (setq loop-result t)) |
1054 | 1051 |
1055 ((eq word 'thereis) | 1052 ((eq word 'thereis) |
1056 (or loop-finish-flag (setq loop-finish-flag (gensym))) | 1053 (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) |
1057 (or loop-result-var (setq loop-result-var (gensym))) | 1054 (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--"))) |
1058 (push (list 'setq loop-finish-flag | 1055 (push (list 'setq loop-finish-flag |
1059 (list 'not (list 'setq loop-result-var (pop args)))) | 1056 (list 'not (list 'setq loop-result-var (pop args)))) |
1060 loop-body)) | 1057 loop-body)) |
1061 | 1058 |
1062 ((memq word '(if when unless)) | 1059 ((memq word '(if when unless)) |
1063 (let* ((cond (pop args)) | 1060 (let* ((cond (pop args)) |
1064 (then (let ((loop-body nil)) | 1061 (then (let ((loop-body nil)) |
1065 (cl-parse-loop-clause) | 1062 (cl-parse-loop-clause) |
1072 (if (eq (car args) 'end) (pop args)) | 1069 (if (eq (car args) 'end) (pop args)) |
1073 (if (eq word 'unless) (setq then (prog1 else (setq else then)))) | 1070 (if (eq word 'unless) (setq then (prog1 else (setq else then)))) |
1074 (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) | 1071 (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) |
1075 (if simple (nth 1 else) (list (nth 2 else)))))) | 1072 (if simple (nth 1 else) (list (nth 2 else)))))) |
1076 (if (cl-expr-contains form 'it) | 1073 (if (cl-expr-contains form 'it) |
1077 (let ((temp (gensym))) | 1074 (let ((temp (make-symbol "--cl-var--"))) |
1078 (push (list temp) loop-bindings) | 1075 (push (list temp) loop-bindings) |
1079 (setq form (list* 'if (list 'setq temp cond) | 1076 (setq form (list* 'if (list 'setq temp cond) |
1080 (subst temp 'it form)))) | 1077 (subst temp 'it form)))) |
1081 (setq form (list* 'if cond form))) | 1078 (setq form (list* 'if cond form))) |
1082 (push (if simple (list 'progn form t) form) loop-body)))) | 1079 (push (if simple (list 'progn form t) form) loop-body)))) |
1086 (or (consp (car args)) (error "Syntax error on `do' clause")) | 1083 (or (consp (car args)) (error "Syntax error on `do' clause")) |
1087 (while (consp (car args)) (push (pop args) body)) | 1084 (while (consp (car args)) (push (pop args) body)) |
1088 (push (cons 'progn (nreverse (cons t body))) loop-body))) | 1085 (push (cons 'progn (nreverse (cons t body))) loop-body))) |
1089 | 1086 |
1090 ((eq word 'return) | 1087 ((eq word 'return) |
1091 (or loop-finish-flag (setq loop-finish-flag (gensym))) | 1088 (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--"))) |
1092 (or loop-result-var (setq loop-result-var (gensym))) | 1089 (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--"))) |
1093 (push (list 'setq loop-result-var (pop args) | 1090 (push (list 'setq loop-result-var (pop args) |
1094 loop-finish-flag nil) loop-body)) | 1091 loop-finish-flag nil) loop-body)) |
1095 | 1092 |
1096 (t | 1093 (t |
1097 (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) | 1094 (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) |
1098 (or handler (error "Expected a loop keyword, found %s" word)) | 1095 (or handler (error "Expected a loop keyword, found %s" word)) |
1099 (funcall handler)))) | 1096 (funcall handler)))) |
1107 (and par p | 1104 (and par p |
1108 (progn | 1105 (progn |
1109 (setq par nil p specs) | 1106 (setq par nil p specs) |
1110 (while p | 1107 (while p |
1111 (or (cl-const-expr-p (cadar p)) | 1108 (or (cl-const-expr-p (cadar p)) |
1112 (let ((temp (gensym))) | 1109 (let ((temp (make-symbol "--cl-var--"))) |
1113 (push (list temp (cadar p)) temps) | 1110 (push (list temp (cadar p)) temps) |
1114 (setcar (cdar p) temp))) | 1111 (setcar (cdar p) temp))) |
1115 (setq p (cdr p))))) | 1112 (setq p (cdr p))))) |
1116 (while specs | 1113 (while specs |
1117 (if (and (consp (car specs)) (listp (caar specs))) | 1114 (if (and (consp (car specs)) (listp (caar specs))) |
1118 (let* ((spec (caar specs)) (nspecs nil) | 1115 (let* ((spec (caar specs)) (nspecs nil) |
1119 (expr (cadr (pop specs))) | 1116 (expr (cadr (pop specs))) |
1120 (temp (cdr (or (assq spec loop-destr-temps) | 1117 (temp (cdr (or (assq spec loop-destr-temps) |
1121 (car (push (cons spec (or (last spec 0) | 1118 (car (push (cons spec (or (last spec 0) |
1122 (gensym))) | 1119 (make-symbol "--cl-var--"))) |
1123 loop-destr-temps)))))) | 1120 loop-destr-temps)))))) |
1124 (push (list temp expr) new) | 1121 (push (list temp expr) new) |
1125 (while (consp spec) | 1122 (while (consp spec) |
1126 (push (list (pop spec) | 1123 (push (list (pop spec) |
1127 (and expr (list (if spec 'pop 'car) temp))) | 1124 (and expr (list (if spec 'pop 'car) temp))) |
1128 nspecs)) | 1125 nspecs)) |
1141 (progn (push (list (list var def)) loop-bindings) | 1138 (progn (push (list (list var def)) loop-bindings) |
1142 (push var loop-accum-vars))) | 1139 (push var loop-accum-vars))) |
1143 var) | 1140 var) |
1144 (or loop-accum-var | 1141 (or loop-accum-var |
1145 (progn | 1142 (progn |
1146 (push (list (list (setq loop-accum-var (gensym)) def)) | 1143 (push (list (list (setq loop-accum-var (make-symbol "--cl-var--")) def)) |
1147 loop-bindings) | 1144 loop-bindings) |
1148 (setq loop-result (if func (list func loop-accum-var) | 1145 (setq loop-result (if func (list func loop-accum-var) |
1149 loop-accum-var)) | 1146 loop-accum-var)) |
1150 loop-accum-var)))) | 1147 loop-accum-var)))) |
1151 | 1148 |
1212 "Loop over a list. | 1209 "Loop over a list. |
1213 Evaluate BODY with VAR bound to each `car' from LIST, in turn. | 1210 Evaluate BODY with VAR bound to each `car' from LIST, in turn. |
1214 Then evaluate RESULT to get return value, default nil. | 1211 Then evaluate RESULT to get return value, default nil. |
1215 | 1212 |
1216 \(fn (VAR LIST [RESULT]) BODY...)" | 1213 \(fn (VAR LIST [RESULT]) BODY...)" |
1217 (let ((temp (gensym "--dolist-temp--"))) | 1214 (let ((temp (make-symbol "--cl-dolist-temp--"))) |
1218 (list 'block nil | 1215 (list 'block nil |
1219 (list* 'let (list (list temp (nth 1 spec)) (car spec)) | 1216 (list* 'let (list (list temp (nth 1 spec)) (car spec)) |
1220 (list* 'while temp (list 'setq (car spec) (list 'car temp)) | 1217 (list* 'while temp (list 'setq (car spec) (list 'car temp)) |
1221 (append body (list (list 'setq temp | 1218 (append body (list (list 'setq temp |
1222 (list 'cdr temp))))) | 1219 (list 'cdr temp))))) |
1229 Evaluate BODY with VAR bound to successive integers from 0, inclusive, | 1226 Evaluate BODY with VAR bound to successive integers from 0, inclusive, |
1230 to COUNT, exclusive. Then evaluate RESULT to get return value, default | 1227 to COUNT, exclusive. Then evaluate RESULT to get return value, default |
1231 nil. | 1228 nil. |
1232 | 1229 |
1233 \(fn (VAR COUNT [RESULT]) BODY...)" | 1230 \(fn (VAR COUNT [RESULT]) BODY...)" |
1234 (let ((temp (gensym "--dotimes-temp--"))) | 1231 (let ((temp (make-symbol "--cl-dotimes-temp--"))) |
1235 (list 'block nil | 1232 (list 'block nil |
1236 (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0)) | 1233 (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0)) |
1237 (list* 'while (list '< (car spec) temp) | 1234 (list* 'while (list '< (car spec) temp) |
1238 (append body (list (list 'incf (car spec))))) | 1235 (append body (list (list 'incf (car spec))))) |
1239 (or (cdr (cdr spec)) '(nil)))))) | 1236 (or (cdr (cdr spec)) '(nil)))))) |
1315 Unlike `flet', this macro is fully compliant with the Common Lisp standard. | 1312 Unlike `flet', this macro is fully compliant with the Common Lisp standard. |
1316 | 1313 |
1317 \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" | 1314 \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" |
1318 (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) | 1315 (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) |
1319 (while bindings | 1316 (while bindings |
1320 (let ((var (gensym))) | 1317 (let ((var (make-symbol "--cl-var--"))) |
1321 (push var vars) | 1318 (push var vars) |
1322 (push (list 'function* (cons 'lambda (cdar bindings))) sets) | 1319 (push (list 'function* (cons 'lambda (cdar bindings))) sets) |
1323 (push var sets) | 1320 (push var sets) |
1324 (push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args) | 1321 (push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args) |
1325 (list 'list* '(quote funcall) (list 'quote var) | 1322 (list 'list* '(quote funcall) (list 'quote var) |
1368 lexical closures as in Common Lisp." | 1365 lexical closures as in Common Lisp." |
1369 (let* ((cl-closure-vars cl-closure-vars) | 1366 (let* ((cl-closure-vars cl-closure-vars) |
1370 (vars (mapcar (function | 1367 (vars (mapcar (function |
1371 (lambda (x) | 1368 (lambda (x) |
1372 (or (consp x) (setq x (list x))) | 1369 (or (consp x) (setq x (list x))) |
1373 (push (gensym (format "--%s--" (car x))) | 1370 (push (make-symbol (format "--cl-%s--" (car x))) |
1374 cl-closure-vars) | 1371 cl-closure-vars) |
1375 (set (car cl-closure-vars) [bad-lexical-ref]) | 1372 (set (car cl-closure-vars) [bad-lexical-ref]) |
1376 (list (car x) (cadr x) (car cl-closure-vars)))) | 1373 (list (car x) (cadr x) (car cl-closure-vars)))) |
1377 bindings)) | 1374 bindings)) |
1378 (ebody | 1375 (ebody |
1379 (cl-macroexpand-all | 1376 (cl-macroexpand-all |
1430 is analogous to the Common Lisp `multiple-value-bind' macro, using lists to | 1427 is analogous to the Common Lisp `multiple-value-bind' macro, using lists to |
1431 simulate true multiple return values. For compatibility, (values A B C) is | 1428 simulate true multiple return values. For compatibility, (values A B C) is |
1432 a synonym for (list A B C). | 1429 a synonym for (list A B C). |
1433 | 1430 |
1434 \(fn (SYM SYM...) FORM BODY)" | 1431 \(fn (SYM SYM...) FORM BODY)" |
1435 (let ((temp (gensym)) (n -1)) | 1432 (let ((temp (make-symbol "--cl-var--")) (n -1)) |
1436 (list* 'let* (cons (list temp form) | 1433 (list* 'let* (cons (list temp form) |
1437 (mapcar (function | 1434 (mapcar (function |
1438 (lambda (v) | 1435 (lambda (v) |
1439 (list v (list 'nth (setq n (1+ n)) temp)))) | 1436 (list v (list 'nth (setq n (1+ n)) temp)))) |
1440 vars)) | 1437 vars)) |
1449 | 1446 |
1450 \(fn (SYM SYM...) FORM)" | 1447 \(fn (SYM SYM...) FORM)" |
1451 (cond ((null vars) (list 'progn form nil)) | 1448 (cond ((null vars) (list 'progn form nil)) |
1452 ((null (cdr vars)) (list 'setq (car vars) (list 'car form))) | 1449 ((null (cdr vars)) (list 'setq (car vars) (list 'car form))) |
1453 (t | 1450 (t |
1454 (let* ((temp (gensym)) (n 0)) | 1451 (let* ((temp (make-symbol "--cl-var--")) (n 0)) |
1455 (list 'let (list (list temp form)) | 1452 (list 'let (list (list temp form)) |
1456 (list 'prog1 (list 'setq (pop vars) (list 'car temp)) | 1453 (list 'prog1 (list 'setq (pop vars) (list 'car temp)) |
1457 (cons 'setq (apply 'nconc | 1454 (cons 'setq (apply 'nconc |
1458 (mapcar (function | 1455 (mapcar (function |
1459 (lambda (v) | 1456 (lambda (v) |
1588 rest-temps (intern (format "--%s--temp--" restarg)) | 1585 rest-temps (intern (format "--%s--temp--" restarg)) |
1589 tempsr (append temps (list rest-temps))) | 1586 tempsr (append temps (list rest-temps))) |
1590 (setq largsr largs tempsr temps)) | 1587 (setq largsr largs tempsr temps)) |
1591 (let ((p1 largs) (p2 temps)) | 1588 (let ((p1 largs) (p2 temps)) |
1592 (while p1 | 1589 (while p1 |
1593 (setq lets1 (cons (list (car p2) | 1590 (setq lets1 (cons `(,(car p2) |
1594 (list 'gensym (format "--%s--" (car p1)))) | 1591 (make-symbol ,(format "--cl-%s--" (car p1)))) |
1595 lets1) | 1592 lets1) |
1596 lets2 (cons (list (car p1) (car p2)) lets2) | 1593 lets2 (cons (list (car p1) (car p2)) lets2) |
1597 p1 (cdr p1) p2 (cdr p2)))) | 1594 p1 (cdr p1) p2 (cdr p2)))) |
1598 (if restarg (setq lets2 (cons (list restarg rest-temps) lets2))) | 1595 (if restarg (setq lets2 (cons (list restarg rest-temps) lets2))) |
1599 (append (list 'define-setf-method func arg1) | 1596 `(define-setf-method ,func ,arg1 |
1600 (and docstr (list docstr)) | 1597 ,@(and docstr (list docstr)) |
1601 (list | 1598 (let* |
1602 (list 'let* | 1599 ,(nreverse |
1603 (nreverse | 1600 (cons `(,store-temp |
1604 (cons (list store-temp | 1601 (make-symbol ,(format "--cl-%s--" store-var))) |
1605 (list 'gensym (format "--%s--" store-var))) | 1602 (if restarg |
1606 (if restarg | 1603 `((,rest-temps |
1607 (append | 1604 (mapcar (lambda (_) (make-symbol "--cl-var--")) |
1608 (list | 1605 ,restarg)) |
1609 (list rest-temps | 1606 ,@lets1) |
1610 (list 'mapcar '(quote gensym) | 1607 lets1))) |
1611 restarg))) | 1608 (list ; 'values |
1612 lets1) | 1609 (,(if restarg 'list* 'list) ,@tempsr) |
1613 lets1))) | 1610 (,(if restarg 'list* 'list) ,@largsr) |
1614 (list 'list ; 'values | 1611 (list ,store-temp) |
1615 (cons (if restarg 'list* 'list) tempsr) | 1612 (let* |
1616 (cons (if restarg 'list* 'list) largsr) | 1613 ,(nreverse |
1617 (list 'list store-temp) | 1614 (cons (list store-var store-temp) |
1618 (cons 'let* | 1615 lets2)) |
1619 (cons (nreverse | 1616 ,@args) |
1620 (cons (list store-var store-temp) | 1617 (,(if restarg 'list* 'list) |
1621 lets2)) | 1618 ,@(cons (list 'quote func) tempsr)))))) |
1622 args)) | 1619 `(defsetf ,func (&rest args) (store) |
1623 (cons (if restarg 'list* 'list) | 1620 ,(let ((call `(cons ',arg1 |
1624 (cons (list 'quote func) tempsr))))))) | 1621 (append args (list store))))) |
1625 (list 'defsetf func '(&rest args) '(store) | 1622 (if (car args) |
1626 (let ((call (list 'cons (list 'quote arg1) | 1623 `(list 'progn ,call store) |
1627 '(append args (list store))))) | 1624 call))))) |
1628 (if (car args) | |
1629 (list 'list '(quote progn) call 'store) | |
1630 call))))) | |
1631 | 1625 |
1632 ;;; Some standard place types from Common Lisp. | 1626 ;;; Some standard place types from Common Lisp. |
1633 (defsetf aref aset) | 1627 (defsetf aref aset) |
1634 (defsetf car setcar) | 1628 (defsetf car setcar) |
1635 (defsetf cdr setcdr) | 1629 (defsetf cdr setcdr) |
1779 (error "%s is not suitable for use with setf-of-apply" func)) | 1773 (error "%s is not suitable for use with setf-of-apply" func)) |
1780 (list* 'apply (list 'quote (car form)) (cdr form)))) | 1774 (list* 'apply (list 'quote (car form)) (cdr form)))) |
1781 | 1775 |
1782 (define-setf-method nthcdr (n place) | 1776 (define-setf-method nthcdr (n place) |
1783 (let ((method (get-setf-method place cl-macro-environment)) | 1777 (let ((method (get-setf-method place cl-macro-environment)) |
1784 (n-temp (gensym "--nthcdr-n--")) | 1778 (n-temp (make-symbol "--cl-nthcdr-n--")) |
1785 (store-temp (gensym "--nthcdr-store--"))) | 1779 (store-temp (make-symbol "--cl-nthcdr-store--"))) |
1786 (list (cons n-temp (car method)) | 1780 (list (cons n-temp (car method)) |
1787 (cons n (nth 1 method)) | 1781 (cons n (nth 1 method)) |
1788 (list store-temp) | 1782 (list store-temp) |
1789 (list 'let (list (list (car (nth 2 method)) | 1783 (list 'let (list (list (car (nth 2 method)) |
1790 (list 'cl-set-nthcdr n-temp (nth 4 method) | 1784 (list 'cl-set-nthcdr n-temp (nth 4 method) |
1792 (nth 3 method) store-temp) | 1786 (nth 3 method) store-temp) |
1793 (list 'nthcdr n-temp (nth 4 method))))) | 1787 (list 'nthcdr n-temp (nth 4 method))))) |
1794 | 1788 |
1795 (define-setf-method getf (place tag &optional def) | 1789 (define-setf-method getf (place tag &optional def) |
1796 (let ((method (get-setf-method place cl-macro-environment)) | 1790 (let ((method (get-setf-method place cl-macro-environment)) |
1797 (tag-temp (gensym "--getf-tag--")) | 1791 (tag-temp (make-symbol "--cl-getf-tag--")) |
1798 (def-temp (gensym "--getf-def--")) | 1792 (def-temp (make-symbol "--cl-getf-def--")) |
1799 (store-temp (gensym "--getf-store--"))) | 1793 (store-temp (make-symbol "--cl-getf-store--"))) |
1800 (list (append (car method) (list tag-temp def-temp)) | 1794 (list (append (car method) (list tag-temp def-temp)) |
1801 (append (nth 1 method) (list tag def)) | 1795 (append (nth 1 method) (list tag def)) |
1802 (list store-temp) | 1796 (list store-temp) |
1803 (list 'let (list (list (car (nth 2 method)) | 1797 (list 'let (list (list (car (nth 2 method)) |
1804 (list 'cl-set-getf (nth 4 method) | 1798 (list 'cl-set-getf (nth 4 method) |
1806 (nth 3 method) store-temp) | 1800 (nth 3 method) store-temp) |
1807 (list 'getf (nth 4 method) tag-temp def-temp)))) | 1801 (list 'getf (nth 4 method) tag-temp def-temp)))) |
1808 | 1802 |
1809 (define-setf-method substring (place from &optional to) | 1803 (define-setf-method substring (place from &optional to) |
1810 (let ((method (get-setf-method place cl-macro-environment)) | 1804 (let ((method (get-setf-method place cl-macro-environment)) |
1811 (from-temp (gensym "--substring-from--")) | 1805 (from-temp (make-symbol "--cl-substring-from--")) |
1812 (to-temp (gensym "--substring-to--")) | 1806 (to-temp (make-symbol "--cl-substring-to--")) |
1813 (store-temp (gensym "--substring-store--"))) | 1807 (store-temp (make-symbol "--cl-substring-store--"))) |
1814 (list (append (car method) (list from-temp to-temp)) | 1808 (list (append (car method) (list from-temp to-temp)) |
1815 (append (nth 1 method) (list from to)) | 1809 (append (nth 1 method) (list from to)) |
1816 (list store-temp) | 1810 (list store-temp) |
1817 (list 'let (list (list (car (nth 2 method)) | 1811 (list 'let (list (list (car (nth 2 method)) |
1818 (list 'cl-set-substring (nth 4 method) | 1812 (list 'cl-set-substring (nth 4 method) |
1824 (defun get-setf-method (place &optional env) | 1818 (defun get-setf-method (place &optional env) |
1825 "Return a list of five values describing the setf-method for PLACE. | 1819 "Return a list of five values describing the setf-method for PLACE. |
1826 PLACE may be any Lisp form which can appear as the PLACE argument to | 1820 PLACE may be any Lisp form which can appear as the PLACE argument to |
1827 a macro like `setf' or `incf'." | 1821 a macro like `setf' or `incf'." |
1828 (if (symbolp place) | 1822 (if (symbolp place) |
1829 (let ((temp (gensym "--setf--"))) | 1823 (let ((temp (make-symbol "--cl-setf--"))) |
1830 (list nil nil (list temp) (list 'setq place temp) place)) | 1824 (list nil nil (list temp) (list 'setq place temp) place)) |
1831 (or (and (symbolp (car place)) | 1825 (or (and (symbolp (car place)) |
1832 (let* ((func (car place)) | 1826 (let* ((func (car place)) |
1833 (name (symbol-name func)) | 1827 (name (symbol-name func)) |
1834 (method (get func 'setf-method)) | 1828 (method (get func 'setf-method)) |
1931 | 1925 |
1932 (defun cl-do-pop (place) | 1926 (defun cl-do-pop (place) |
1933 (if (cl-simple-expr-p place) | 1927 (if (cl-simple-expr-p place) |
1934 (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place))) | 1928 (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place))) |
1935 (let* ((method (cl-setf-do-modify place t)) | 1929 (let* ((method (cl-setf-do-modify place t)) |
1936 (temp (gensym "--pop--"))) | 1930 (temp (make-symbol "--cl-pop--"))) |
1937 (list 'let* | 1931 (list 'let* |
1938 (append (car method) | 1932 (append (car method) |
1939 (list (list temp (nth 2 method)))) | 1933 (list (list temp (nth 2 method)))) |
1940 (list 'prog1 | 1934 (list 'prog1 |
1941 (list 'car temp) | 1935 (list 'car temp) |
1944 (defmacro remf (place tag) | 1938 (defmacro remf (place tag) |
1945 "Remove TAG from property list PLACE. | 1939 "Remove TAG from property list PLACE. |
1946 PLACE may be a symbol, or any generalized variable allowed by `setf'. | 1940 PLACE may be a symbol, or any generalized variable allowed by `setf'. |
1947 The form returns true if TAG was found and removed, nil otherwise." | 1941 The form returns true if TAG was found and removed, nil otherwise." |
1948 (let* ((method (cl-setf-do-modify place t)) | 1942 (let* ((method (cl-setf-do-modify place t)) |
1949 (tag-temp (and (not (cl-const-expr-p tag)) (gensym "--remf-tag--"))) | 1943 (tag-temp (and (not (cl-const-expr-p tag)) (make-symbol "--cl-remf-tag--"))) |
1950 (val-temp (and (not (cl-simple-expr-p place)) | 1944 (val-temp (and (not (cl-simple-expr-p place)) |
1951 (gensym "--remf-place--"))) | 1945 (make-symbol "--cl-remf-place--"))) |
1952 (ttag (or tag-temp tag)) | 1946 (ttag (or tag-temp tag)) |
1953 (tval (or val-temp (nth 2 method)))) | 1947 (tval (or val-temp (nth 2 method)))) |
1954 (list 'let* | 1948 (list 'let* |
1955 (append (car method) | 1949 (append (car method) |
1956 (and val-temp (list (list val-temp (nth 2 method)))) | 1950 (and val-temp (list (list val-temp (nth 2 method)))) |
1988 (first (car args))) | 1982 (first (car args))) |
1989 (while (cdr args) | 1983 (while (cdr args) |
1990 (setq sets (nconc sets (list (pop args) (car args))))) | 1984 (setq sets (nconc sets (list (pop args) (car args))))) |
1991 (nconc (list 'psetf) sets (list (car args) first)))) | 1985 (nconc (list 'psetf) sets (list (car args) first)))) |
1992 (let* ((places (reverse args)) | 1986 (let* ((places (reverse args)) |
1993 (temp (gensym "--rotatef--")) | 1987 (temp (make-symbol "--cl-rotatef--")) |
1994 (form temp)) | 1988 (form temp)) |
1995 (while (cdr places) | 1989 (while (cdr places) |
1996 (let ((method (cl-setf-do-modify (pop places) 'unsafe))) | 1990 (let ((method (cl-setf-do-modify (pop places) 'unsafe))) |
1997 (setq form (list 'let* (car method) | 1991 (setq form (list 'let* (car method) |
1998 (list 'prog1 (nth 2 method) | 1992 (list 'prog1 (nth 2 method) |
2020 (let* ((place (if (symbolp (caar rev)) | 2014 (let* ((place (if (symbolp (caar rev)) |
2021 (list 'symbol-value (list 'quote (caar rev))) | 2015 (list 'symbol-value (list 'quote (caar rev))) |
2022 (caar rev))) | 2016 (caar rev))) |
2023 (value (cadar rev)) | 2017 (value (cadar rev)) |
2024 (method (cl-setf-do-modify place 'no-opt)) | 2018 (method (cl-setf-do-modify place 'no-opt)) |
2025 (save (gensym "--letf-save--")) | 2019 (save (make-symbol "--cl-letf-save--")) |
2026 (bound (and (memq (car place) '(symbol-value symbol-function)) | 2020 (bound (and (memq (car place) '(symbol-value symbol-function)) |
2027 (gensym "--letf-bound--"))) | 2021 (make-symbol "--cl-letf-bound--"))) |
2028 (temp (and (not (cl-const-expr-p value)) (cdr bindings) | 2022 (temp (and (not (cl-const-expr-p value)) (cdr bindings) |
2029 (gensym "--letf-val--")))) | 2023 (make-symbol "--cl-letf-val--")))) |
2030 (setq lets (nconc (car method) | 2024 (setq lets (nconc (car method) |
2031 (if bound | 2025 (if bound |
2032 (list (list bound | 2026 (list (list bound |
2033 (list (if (eq (car place) | 2027 (list (if (eq (car place) |
2034 'symbol-value) | 2028 'symbol-value) |
2095 | 2089 |
2096 \(fn FUNC ARG1 PLACE ARGS...)" | 2090 \(fn FUNC ARG1 PLACE ARGS...)" |
2097 (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func)) | 2091 (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func)) |
2098 (list 'setf place (list* func arg1 place args)) | 2092 (list 'setf place (list* func arg1 place args)) |
2099 (let* ((method (cl-setf-do-modify place (cons 'list args))) | 2093 (let* ((method (cl-setf-do-modify place (cons 'list args))) |
2100 (temp (and (not (cl-const-expr-p arg1)) (gensym "--arg1--"))) | 2094 (temp (and (not (cl-const-expr-p arg1)) (make-symbol "--cl-arg1--"))) |
2101 (rargs (list* (or temp arg1) (nth 2 method) args))) | 2095 (rargs (list* (or temp arg1) (nth 2 method) args))) |
2102 (list 'let* (append (and temp (list (list temp arg1))) (car method)) | 2096 (list 'let* (append (and temp (list (list temp arg1))) (car method)) |
2103 (cl-setf-do-store (nth 1 method) | 2097 (cl-setf-do-store (nth 1 method) |
2104 (if (symbolp func) (cons func rargs) | 2098 (if (symbolp func) (cons func rargs) |
2105 (list* 'funcall (list 'function func) | 2099 (list* 'funcall (list 'function func) |
2108 (defmacro define-modify-macro (name arglist func &optional doc) | 2102 (defmacro define-modify-macro (name arglist func &optional doc) |
2109 "Define a `setf'-like modify macro. | 2103 "Define a `setf'-like modify macro. |
2110 If NAME is called, it combines its PLACE argument with the other arguments | 2104 If NAME is called, it combines its PLACE argument with the other arguments |
2111 from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" | 2105 from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" |
2112 (if (memq '&key arglist) (error "&key not allowed in define-modify-macro")) | 2106 (if (memq '&key arglist) (error "&key not allowed in define-modify-macro")) |
2113 (let ((place (gensym "--place--"))) | 2107 (let ((place (make-symbol "--cl-place--"))) |
2114 (list 'defmacro* name (cons place arglist) doc | 2108 (list 'defmacro* name (cons place arglist) doc |
2115 (list* (if (memq '&rest arglist) 'list* 'list) | 2109 (list* (if (memq '&rest arglist) 'list* 'list) |
2116 '(quote callf) (list 'quote func) place | 2110 '(quote callf) (list 'quote func) place |
2117 (cl-arglist-args arglist))))) | 2111 (cl-arglist-args arglist))))) |
2118 | 2112 |
2332 side-eff)) | 2326 side-eff)) |
2333 forms) | 2327 forms) |
2334 (cons 'progn (nreverse (cons (list 'quote name) forms))))) | 2328 (cons 'progn (nreverse (cons (list 'quote name) forms))))) |
2335 | 2329 |
2336 (defun cl-struct-setf-expander (x name accessor pred-form pos) | 2330 (defun cl-struct-setf-expander (x name accessor pred-form pos) |
2337 (let* ((temp (gensym "--x--")) (store (gensym "--store--"))) | 2331 (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--"))) |
2338 (list (list temp) (list x) (list store) | 2332 (list (list temp) (list x) (list store) |
2339 (append '(progn) | 2333 (append '(progn) |
2340 (and pred-form | 2334 (and pred-form |
2341 (list (list 'or (subst temp 'cl-x pred-form) | 2335 (list (list 'or (subst temp 'cl-x pred-form) |
2342 (list 'error | 2336 (list 'error |
2408 (defmacro check-type (form type &optional string) | 2402 (defmacro check-type (form type &optional string) |
2409 "Verify that FORM is of type TYPE; signal an error if not. | 2403 "Verify that FORM is of type TYPE; signal an error if not. |
2410 STRING is an optional description of the desired type." | 2404 STRING is an optional description of the desired type." |
2411 (and (or (not (cl-compiling-file)) | 2405 (and (or (not (cl-compiling-file)) |
2412 (< cl-optimize-speed 3) (= cl-optimize-safety 3)) | 2406 (< cl-optimize-speed 3) (= cl-optimize-safety 3)) |
2413 (let* ((temp (if (cl-simple-expr-p form 3) form (gensym))) | 2407 (let* ((temp (if (cl-simple-expr-p form 3) |
2408 form (make-symbol "--cl-var--"))) | |
2414 (body (list 'or (cl-make-type-test temp type) | 2409 (body (list 'or (cl-make-type-test temp type) |
2415 (list 'signal '(quote wrong-type-argument) | 2410 (list 'signal '(quote wrong-type-argument) |
2416 (list 'list (or string (list 'quote type)) | 2411 (list 'list (or string (list 'quote type)) |
2417 temp (list 'quote form)))))) | 2412 temp (list 'quote form)))))) |
2418 (if (eq temp form) (list 'progn body nil) | 2413 (if (eq temp form) (list 'progn body nil) |
2605 (define-compiler-macro typep (&whole form val type) | 2600 (define-compiler-macro typep (&whole form val type) |
2606 (if (cl-const-expr-p type) | 2601 (if (cl-const-expr-p type) |
2607 (let ((res (cl-make-type-test val (cl-const-expr-val type)))) | 2602 (let ((res (cl-make-type-test val (cl-const-expr-val type)))) |
2608 (if (or (memq (cl-expr-contains res val) '(nil 1)) | 2603 (if (or (memq (cl-expr-contains res val) '(nil 1)) |
2609 (cl-simple-expr-p val)) res | 2604 (cl-simple-expr-p val)) res |
2610 (let ((temp (gensym))) | 2605 (let ((temp (make-symbol "--cl-var--"))) |
2611 (list 'let (list (list temp val)) (subst temp val res))))) | 2606 (list 'let (list (list temp val)) (subst temp val res))))) |
2612 form)) | 2607 form)) |
2613 | 2608 |
2614 | 2609 |
2615 (mapcar (function | 2610 (mapc (lambda (y) |
2616 (lambda (y) | 2611 (put (car y) 'side-effect-free t) |
2617 (put (car y) 'side-effect-free t) | 2612 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) |
2618 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) | 2613 (put (car y) 'cl-compiler-macro |
2619 (put (car y) 'cl-compiler-macro | 2614 `(lambda (w x) |
2620 (list 'lambda '(w x) | 2615 ,(if (symbolp (cadr y)) |
2621 (if (symbolp (cadr y)) | 2616 `(list ',(cadr y) |
2622 (list 'list (list 'quote (cadr y)) | 2617 (list ',(caddr y) x)) |
2623 (list 'list (list 'quote (caddr y)) 'x)) | 2618 (cons 'list (cdr y)))))) |
2624 (cons 'list (cdr y))))))) | 2619 '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) |
2625 '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) | 2620 (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x) |
2626 (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x) | 2621 (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x) |
2627 (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x) | 2622 (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0) |
2628 (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0) | 2623 (caaar car caar) (caadr car cadr) (cadar car cdar) |
2629 (caaar car caar) (caadr car cadr) (cadar car cdar) | 2624 (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr) |
2630 (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr) | 2625 (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar) |
2631 (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar) | 2626 (caaadr car caadr) (caadar car cadar) (caaddr car caddr) |
2632 (caaadr car caadr) (caadar car cadar) (caaddr car caddr) | 2627 (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar) |
2633 (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar) | 2628 (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr) |
2634 (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr) | 2629 (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar) |
2635 (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar) | 2630 (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) )) |
2636 (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) )) | |
2637 | 2631 |
2638 ;;; Things that are inline. | 2632 ;;; Things that are inline. |
2639 (proclaim '(inline floatp-safe acons map concatenate notany notevery | 2633 (proclaim '(inline floatp-safe acons map concatenate notany notevery |
2640 cl-set-elt revappend nreconc gethash)) | 2634 cl-set-elt revappend nreconc gethash)) |
2641 | 2635 |
2642 ;;; Things that are side-effect-free. | 2636 ;;; Things that are side-effect-free. |
2643 (mapcar (function (lambda (x) (put x 'side-effect-free t))) | 2637 (mapc (lambda (x) (put x 'side-effect-free t)) |
2644 '(oddp evenp signum last butlast ldiff pairlis gcd lcm | 2638 '(oddp evenp signum last butlast ldiff pairlis gcd lcm |
2645 isqrt floor* ceiling* truncate* round* mod* rem* subseq | 2639 isqrt floor* ceiling* truncate* round* mod* rem* subseq |
2646 list-length get* getf)) | 2640 list-length get* getf)) |
2647 | 2641 |
2648 ;;; Things that are side-effect-and-error-free. | 2642 ;;; Things that are side-effect-and-error-free. |
2649 (mapcar (function (lambda (x) (put x 'side-effect-free 'error-free))) | 2643 (mapc (lambda (x) (put x 'side-effect-free 'error-free)) |
2650 '(eql floatp-safe list* subst acons equalp random-state-p | 2644 '(eql floatp-safe list* subst acons equalp random-state-p |
2651 copy-tree sublis)) | 2645 copy-tree sublis)) |
2652 | 2646 |
2653 | 2647 |
2654 (run-hooks 'cl-macs-load-hook) | 2648 (run-hooks 'cl-macs-load-hook) |
2655 | 2649 |
2656 ;;; Local variables: | 2650 ;;; Local variables: |
2657 ;;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete noruntime) | 2651 ;;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete noruntime) |
2658 ;;; End: | 2652 ;;; End: |
2659 | 2653 |
2660 ;;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46 | 2654 ;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46 |
2661 ;;; cl-macs.el ends here | 2655 ;;; cl-macs.el ends here |