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) |
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 |
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 |
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 |
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 |
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))) |
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 |
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 |
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))) |
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) |
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)) |
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'")) |
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)) |
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))) |
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'")) |
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 |
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 |
|
|
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)) |
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))) |
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)) |
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)))) |
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)))) |
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))))) |
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) |
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)) |
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)) |
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) |
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) |
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)) |
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) |
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 |
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) |
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) |
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) |
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) |
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)) |
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)))) |
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* |
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))) |
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 |
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) |
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 |
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 |
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)) |
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) |
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 |