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