Revision: miles@gnu.org--gnu-2004/emacs--unicode--0--patch-72
Merge from emacs--cvs-trunk--0 Patches applied: * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-693 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-695 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-696 Merge from gnus--rel--5.10 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-697 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-702 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-703 Merge from gnus--rel--5.10 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-704 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-708 Update from CVS * miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-72 Update from CVS * miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-73 Merge from emacs--cvs-trunk--0
This commit is contained in:
Miles Bader
commit
1483965680
75 changed files with 12732 additions and 7471 deletions
|
|
@ -231,16 +231,16 @@
|
|||
(cons 'progn
|
||||
(mapcar
|
||||
(lambda (sexp)
|
||||
(let ((fn (car-safe sexp)))
|
||||
(if (and (symbolp fn)
|
||||
(or (cdr (assq fn byte-compile-function-environment))
|
||||
(and (fboundp fn)
|
||||
(not (or (cdr (assq fn byte-compile-macro-environment))
|
||||
(and (consp (setq fn (symbol-function fn)))
|
||||
(eq (car fn) 'macro))
|
||||
(subrp fn))))))
|
||||
(byte-compile-inline-expand sexp)
|
||||
sexp)))
|
||||
(let ((f (car-safe sexp)))
|
||||
(if (and (symbolp f)
|
||||
(or (cdr (assq f byte-compile-function-environment))
|
||||
(not (or (not (fboundp f))
|
||||
(cdr (assq f byte-compile-macro-environment))
|
||||
(and (consp (setq f (symbol-function f)))
|
||||
(eq (car f) 'macro))
|
||||
(subrp f)))))
|
||||
(byte-compile-inline-expand sexp)
|
||||
sexp)))
|
||||
(cdr form))))
|
||||
|
||||
|
||||
|
|
@ -1370,10 +1370,9 @@ of FORM by signalling the error at compile-time."
|
|||
;; before each insn (or its label).
|
||||
(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable)
|
||||
(let ((length (length bytes))
|
||||
(ptr 0) optr tag tags op offset
|
||||
(ptr 0) optr tags op offset
|
||||
lap tmp
|
||||
endtag
|
||||
(retcount 0))
|
||||
endtag)
|
||||
(while (not (= ptr length))
|
||||
(or make-spliceable
|
||||
(setq lap (cons ptr lap)))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility)
|
||||
|
||||
;; Copyright (C) 1993 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 1993, 2004 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Dave Gillespie <daveg@synaptics.com>
|
||||
;; Version: 2.02
|
||||
|
|
@ -139,7 +139,7 @@
|
|||
;; Internal routines.
|
||||
|
||||
(defun pair-with-newsyms (oldforms)
|
||||
(let ((newsyms (mapcar (function (lambda (x) (gensym))) oldforms)))
|
||||
(let ((newsyms (mapcar (lambda (x) (make-symbol "--cl-var--")) oldforms)))
|
||||
(Values (mapcar* 'list newsyms oldforms) newsyms)))
|
||||
|
||||
(defun zip-lists (evens odds)
|
||||
|
|
@ -185,5 +185,5 @@
|
|||
|
||||
(provide 'cl-compat)
|
||||
|
||||
;;; arch-tag: 9996bb4f-aaf5-4592-b436-bf64759a3163
|
||||
;; arch-tag: 9996bb4f-aaf5-4592-b436-bf64759a3163
|
||||
;;; cl-compat.el ends here
|
||||
|
|
|
|||
|
|
@ -292,7 +292,7 @@ ARGLIST allows full Common Lisp conventions."
|
|||
(laterarg nil) (exactarg nil) minarg)
|
||||
(or num (setq num 0))
|
||||
(if (listp (cadr restarg))
|
||||
(setq restarg (gensym "--rest--"))
|
||||
(setq restarg (make-symbol "--cl-rest--"))
|
||||
(setq restarg (cadr restarg)))
|
||||
(push (list restarg expr) bind-lets)
|
||||
(if (eq (car args) '&whole)
|
||||
|
|
@ -354,7 +354,7 @@ ARGLIST allows full Common Lisp conventions."
|
|||
(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)))
|
||||
(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,7 +377,7 @@ ARGLIST allows full Common Lisp conventions."
|
|||
(setq keys (nreverse keys))
|
||||
(or (and (eq (car args) '&allow-other-keys) (pop args))
|
||||
(null keys) (= safety 0)
|
||||
(let* ((var (gensym "--keys--"))
|
||||
(let* ((var (make-symbol "--cl-keys--"))
|
||||
(allow '(:allow-other-keys))
|
||||
(check (list
|
||||
'while var
|
||||
|
|
@ -494,7 +494,7 @@ If no clause succeeds, case returns nil. A single atom may be used in
|
|||
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)))
|
||||
(let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
|
||||
(head-list nil)
|
||||
(body (cons
|
||||
'cond
|
||||
|
|
@ -530,7 +530,7 @@ Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it
|
|||
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)))
|
||||
(let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
|
||||
(type-list nil)
|
||||
(body (cons
|
||||
'cond
|
||||
|
|
@ -644,10 +644,10 @@ Valid clauses are:
|
|||
(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))
|
||||
(push `((,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)))
|
||||
(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,16 +658,16 @@ Valid clauses are:
|
|||
(list 'block '--cl-finish--
|
||||
(subst
|
||||
(if (eq (car ands) t) while-body
|
||||
(cons (list 'or (car ands)
|
||||
'(return-from --cl-finish--
|
||||
nil))
|
||||
(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)
|
||||
(list (list 'if loop-finish-flag
|
||||
(cons 'progn epilogue) 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,7 +682,7 @@ Valid clauses are:
|
|||
(setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))
|
||||
(list* 'block loop-name body)))))
|
||||
|
||||
(defun cl-parse-loop-clause () ; uses args, loop-*
|
||||
(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,7 +715,7 @@ Valid clauses are:
|
|||
(let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
|
||||
(ands nil))
|
||||
(while
|
||||
(let ((var (or (pop args) (gensym))))
|
||||
(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,26 +738,28 @@ Valid clauses are:
|
|||
'(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)))
|
||||
(end-var (and (not (cl-const-expr-p end))
|
||||
(make-symbol "--cl-var--")))
|
||||
(step-var (and (not (cl-const-expr-p step))
|
||||
(gensym))))
|
||||
(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))
|
||||
loop-for-bindings))
|
||||
(if end
|
||||
(push (list
|
||||
(if down (if excl '> '>=) (if excl '< '<=))
|
||||
var (or end-var end)) loop-body))
|
||||
(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)))
|
||||
(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))))
|
||||
(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,18 +768,18 @@ Valid clauses are:
|
|||
(progn
|
||||
(push (list var nil) loop-for-bindings)
|
||||
(push (list var (if on temp (list 'car temp)))
|
||||
loop-for-sets))))
|
||||
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)))
|
||||
(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,68 +787,68 @@ Valid clauses are:
|
|||
(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 `(,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
|
||||
(list 'if
|
||||
(or loop-first-flag
|
||||
(setq loop-first-flag (gensym)))
|
||||
start then)))
|
||||
loop-for-sets))))
|
||||
(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 (gensym)) (temp-idx (gensym)))
|
||||
(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)
|
||||
(list 'length temp-vec)) loop-body)
|
||||
(if (eq word 'across-ref)
|
||||
(push (list var (list 'aref temp-vec temp-idx))
|
||||
loop-symbol-macs)
|
||||
loop-symbol-macs)
|
||||
(push (list var nil) loop-for-bindings)
|
||||
(push (list var (list 'aref temp-vec temp-idx))
|
||||
loop-for-sets))))
|
||||
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-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"))
|
||||
(gensym))))
|
||||
(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 (gensym)))
|
||||
(let ((temp-len (make-symbol "--cl-len--")))
|
||||
(push (list temp-len (list 'length temp-seq))
|
||||
loop-for-bindings)
|
||||
loop-for-bindings)
|
||||
(push (list var (list 'elt temp-seq temp-idx))
|
||||
loop-symbol-macs)
|
||||
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)
|
||||
(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))
|
||||
(list 'pop temp-seq)
|
||||
(list 'aref temp-seq temp-idx)))
|
||||
loop-for-sets))
|
||||
(push (list temp-idx (list '1+ temp-idx))
|
||||
loop-for-steps)))
|
||||
loop-for-steps)))
|
||||
|
||||
((memq word hash-types)
|
||||
(or (memq (car args) '(in of)) (error "Expected `of'"))
|
||||
|
|
@ -857,21 +859,17 @@ Valid clauses are:
|
|||
(not (eq (caadr args) word)))
|
||||
(cadr (cl-pop2 args))
|
||||
(error "Bad `using' clause"))
|
||||
(gensym))))
|
||||
(make-symbol "--cl-var--"))))
|
||||
(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))))
|
||||
`(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
|
||||
(list 'mapatoms (list 'function
|
||||
(list* 'lambda (list var)
|
||||
'--cl-map)) ob))))
|
||||
`(mapatoms (lambda (,var) . --cl-map) ,ob))))
|
||||
|
||||
((memq word '(overlay overlays extent extents))
|
||||
(let ((buf nil) (from nil) (to nil))
|
||||
|
|
@ -880,14 +878,15 @@ Valid clauses are:
|
|||
((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))))
|
||||
`(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 (gensym)) (var2 (gensym)))
|
||||
(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,10 +897,9 @@ Valid clauses are:
|
|||
(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))))
|
||||
`(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,37 +910,36 @@ Valid clauses are:
|
|||
(not (eq (caadr args) word)))
|
||||
(cadr (cl-pop2 args))
|
||||
(error "Bad `using' clause"))
|
||||
(gensym))))
|
||||
(make-symbol "--cl-var--"))))
|
||||
(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))))
|
||||
`(,(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 (gensym)))
|
||||
(let ((temp (make-symbol "--cl-var--")))
|
||||
(push (list var '(selected-frame))
|
||||
loop-for-bindings)
|
||||
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)
|
||||
(list 'or temp (list 'setq temp var)))
|
||||
loop-body)
|
||||
(push (list var (list 'next-frame var))
|
||||
loop-for-steps)))
|
||||
loop-for-steps)))
|
||||
|
||||
((memq word '(window windows))
|
||||
(let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
|
||||
(temp (gensym)))
|
||||
(temp (make-symbol "--cl-var--")))
|
||||
(push (list var (if scr
|
||||
(list 'frame-selected-window scr)
|
||||
'(selected-window)))
|
||||
loop-for-bindings)
|
||||
(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)
|
||||
(list 'or temp (list 'setq temp var)))
|
||||
loop-body)
|
||||
(push (list var (list 'next-window var)) loop-for-steps)))
|
||||
|
||||
(t
|
||||
|
|
@ -960,15 +957,15 @@ Valid clauses are:
|
|||
loop-bindings)))
|
||||
(if loop-for-sets
|
||||
(push (list 'progn
|
||||
(cl-loop-let (nreverse loop-for-sets) 'setq ands)
|
||||
t) loop-body))
|
||||
(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))))
|
||||
(apply 'append (nreverse loop-for-steps)))
|
||||
loop-steps))))
|
||||
|
||||
((eq word 'repeat)
|
||||
(let ((temp (gensym)))
|
||||
(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,23 +975,23 @@ Valid clauses are:
|
|||
(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))))
|
||||
(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)))
|
||||
(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,19 +1015,19 @@ Valid clauses are:
|
|||
|
||||
((memq word '(minimize minimizing maximize maximizing))
|
||||
(let* ((what (pop args))
|
||||
(temp (if (cl-simple-expr-p what) what (gensym)))
|
||||
(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)))
|
||||
(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)
|
||||
(and (eq (car args) '=) (cl-pop2 args)))
|
||||
bindings)
|
||||
(eq (car args) 'and))
|
||||
(pop args))
|
||||
(push (nreverse bindings) loop-bindings)))
|
||||
|
|
@ -1042,22 +1039,22 @@ Valid clauses are:
|
|||
(push (list 'not (pop args)) loop-body))
|
||||
|
||||
((eq word 'always)
|
||||
(or loop-finish-flag (setq loop-finish-flag (gensym)))
|
||||
(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 (gensym)))
|
||||
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
|
||||
(push (list 'setq loop-finish-flag (list 'not (pop args)))
|
||||
loop-body)
|
||||
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)))
|
||||
(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))
|
||||
(list 'not (list 'setq loop-result-var (pop args))))
|
||||
loop-body))
|
||||
|
||||
((memq word '(if when unless))
|
||||
(let* ((cond (pop args))
|
||||
|
|
@ -1074,7 +1071,7 @@ Valid clauses are:
|
|||
(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)))
|
||||
(let ((temp (make-symbol "--cl-var--")))
|
||||
(push (list temp) loop-bindings)
|
||||
(setq form (list* 'if (list 'setq temp cond)
|
||||
(subst temp 'it form))))
|
||||
|
|
@ -1088,10 +1085,10 @@ Valid clauses are:
|
|||
(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)))
|
||||
(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))
|
||||
loop-finish-flag nil) loop-body))
|
||||
|
||||
(t
|
||||
(let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
|
||||
|
|
@ -1109,7 +1106,7 @@ Valid clauses are:
|
|||
(setq par nil p specs)
|
||||
(while p
|
||||
(or (cl-const-expr-p (cadar p))
|
||||
(let ((temp (gensym)))
|
||||
(let ((temp (make-symbol "--cl-var--")))
|
||||
(push (list temp (cadar p)) temps)
|
||||
(setcar (cdar p) temp)))
|
||||
(setq p (cdr p)))))
|
||||
|
|
@ -1119,8 +1116,8 @@ Valid clauses are:
|
|||
(expr (cadr (pop specs)))
|
||||
(temp (cdr (or (assq spec loop-destr-temps)
|
||||
(car (push (cons spec (or (last spec 0)
|
||||
(gensym)))
|
||||
loop-destr-temps))))))
|
||||
(make-symbol "--cl-var--")))
|
||||
loop-destr-temps))))))
|
||||
(push (list temp expr) new)
|
||||
(while (consp spec)
|
||||
(push (list (pop spec)
|
||||
|
|
@ -1143,7 +1140,7 @@ Valid clauses are:
|
|||
var)
|
||||
(or loop-accum-var
|
||||
(progn
|
||||
(push (list (list (setq loop-accum-var (gensym)) def))
|
||||
(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,7 +1211,7 @@ Evaluate BODY with VAR bound to each `car' from LIST, in turn.
|
|||
Then evaluate RESULT to get return value, default nil.
|
||||
|
||||
\(fn (VAR LIST [RESULT]) BODY...)"
|
||||
(let ((temp (gensym "--dolist-temp--")))
|
||||
(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,7 +1228,7 @@ to COUNT, exclusive. Then evaluate RESULT to get return value, default
|
|||
nil.
|
||||
|
||||
\(fn (VAR COUNT [RESULT]) BODY...)"
|
||||
(let ((temp (gensym "--dotimes-temp--")))
|
||||
(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,7 +1314,7 @@ Unlike `flet', this macro is fully compliant with the Common Lisp standard.
|
|||
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
|
||||
(let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
|
||||
(while bindings
|
||||
(let ((var (gensym)))
|
||||
(let ((var (make-symbol "--cl-var--")))
|
||||
(push var vars)
|
||||
(push (list 'function* (cons 'lambda (cdar bindings))) sets)
|
||||
(push var sets)
|
||||
|
|
@ -1370,8 +1367,8 @@ lexical closures as in Common Lisp."
|
|||
(vars (mapcar (function
|
||||
(lambda (x)
|
||||
(or (consp x) (setq x (list x)))
|
||||
(push (gensym (format "--%s--" (car x)))
|
||||
cl-closure-vars)
|
||||
(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,7 +1429,7 @@ simulate true multiple return values. For compatibility, (values A B C) is
|
|||
a synonym for (list A B C).
|
||||
|
||||
\(fn (SYM SYM...) FORM BODY)"
|
||||
(let ((temp (gensym)) (n -1))
|
||||
(let ((temp (make-symbol "--cl-var--")) (n -1))
|
||||
(list* 'let* (cons (list temp form)
|
||||
(mapcar (function
|
||||
(lambda (v)
|
||||
|
|
@ -1451,7 +1448,7 @@ values. For compatibility, (values A B C) is a synonym for (list A B C).
|
|||
(cond ((null vars) (list 'progn form nil))
|
||||
((null (cdr vars)) (list 'setq (car vars) (list 'car form)))
|
||||
(t
|
||||
(let* ((temp (gensym)) (n 0))
|
||||
(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,44 +1587,41 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))."
|
|||
(setq largsr largs tempsr temps))
|
||||
(let ((p1 largs) (p2 temps))
|
||||
(while p1
|
||||
(setq lets1 (cons (list (car p2)
|
||||
(list 'gensym (format "--%s--" (car 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)))
|
||||
(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)))))
|
||||
`(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,8 +1775,8 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))."
|
|||
|
||||
(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--")))
|
||||
(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,9 +1788,9 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))."
|
|||
|
||||
(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--")))
|
||||
(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,9 +1802,9 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))."
|
|||
|
||||
(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--")))
|
||||
(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,7 +1820,7 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))."
|
|||
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--")))
|
||||
(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,7 +1927,7 @@ before assigning any PLACEs to the corresponding values.
|
|||
(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--")))
|
||||
(temp (make-symbol "--cl-pop--")))
|
||||
(list 'let*
|
||||
(append (car method)
|
||||
(list (list temp (nth 2 method))))
|
||||
|
|
@ -1946,9 +1940,9 @@ before assigning any PLACEs to the corresponding values.
|
|||
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--")))
|
||||
(tag-temp (and (not (cl-const-expr-p tag)) (make-symbol "--cl-remf-tag--")))
|
||||
(val-temp (and (not (cl-simple-expr-p place))
|
||||
(gensym "--remf-place--")))
|
||||
(make-symbol "--cl-remf-place--")))
|
||||
(ttag (or tag-temp tag))
|
||||
(tval (or val-temp (nth 2 method))))
|
||||
(list 'let*
|
||||
|
|
@ -1990,7 +1984,7 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
|
|||
(setq sets (nconc sets (list (pop args) (car args)))))
|
||||
(nconc (list 'psetf) sets (list (car args) first))))
|
||||
(let* ((places (reverse args))
|
||||
(temp (gensym "--rotatef--"))
|
||||
(temp (make-symbol "--cl-rotatef--"))
|
||||
(form temp))
|
||||
(while (cdr places)
|
||||
(let ((method (cl-setf-do-modify (pop places) 'unsafe)))
|
||||
|
|
@ -2022,11 +2016,11 @@ the PLACE is not modified before executing BODY.
|
|||
(caar rev)))
|
||||
(value (cadar rev))
|
||||
(method (cl-setf-do-modify place 'no-opt))
|
||||
(save (gensym "--letf-save--"))
|
||||
(save (make-symbol "--cl-letf-save--"))
|
||||
(bound (and (memq (car place) '(symbol-value symbol-function))
|
||||
(gensym "--letf-bound--")))
|
||||
(make-symbol "--cl-letf-bound--")))
|
||||
(temp (and (not (cl-const-expr-p value)) (cdr bindings)
|
||||
(gensym "--letf-val--"))))
|
||||
(make-symbol "--cl-letf-val--"))))
|
||||
(setq lets (nconc (car method)
|
||||
(if bound
|
||||
(list (list bound
|
||||
|
|
@ -2097,7 +2091,7 @@ Like `callf', but PLACE is the second argument of FUNC, not the first.
|
|||
(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--")))
|
||||
(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,7 +2104,7 @@ Like `callf', but PLACE is the second argument of FUNC, not the first.
|
|||
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--")))
|
||||
(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,7 +2328,7 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors.
|
|||
(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--")))
|
||||
(let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--")))
|
||||
(list (list temp) (list x) (list store)
|
||||
(append '(progn)
|
||||
(and pred-form
|
||||
|
|
@ -2410,7 +2404,8 @@ TYPE is a Common Lisp-style type specifier."
|
|||
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)))
|
||||
(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,48 +2602,47 @@ surrounded by (block NAME ...).
|
|||
(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)))
|
||||
(let ((temp (make-symbol "--cl-var--")))
|
||||
(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) ))
|
||||
(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.
|
||||
(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))
|
||||
(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.
|
||||
(mapcar (function (lambda (x) (put x 'side-effect-free 'error-free)))
|
||||
'(eql floatp-safe list* subst acons equalp random-state-p
|
||||
copy-tree sublis))
|
||||
(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,5 +2651,5 @@ surrounded by (block NAME ...).
|
|||
;;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete noruntime)
|
||||
;;; End:
|
||||
|
||||
;;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46
|
||||
;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46
|
||||
;;; cl-macs.el ends here
|
||||
|
|
|
|||
|
|
@ -62,13 +62,13 @@
|
|||
;; (define-derived-mode foo ...), (define-minor-mode foo)
|
||||
(concat
|
||||
"^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\
|
||||
\[^cgv\W]\\w+\\*?\\)\\|define-minor-mode\
|
||||
ine-minor-mode\\|un-cvs-mode\\|foo\\|[^cfgv]\\w+\\*?\\)\
|
||||
\\|easy-mmode-define-global-mode\\)" find-function-space-re
|
||||
"\\('\\|\(quote \\)?%s\\(\\s-\\|$\\|\(\\|\)\\)")
|
||||
"The regexp used by `find-function' to search for a function definition.
|
||||
Note it must contain a `%s' at the place where `format'
|
||||
should insert the function name. The default value avoids `defconst',
|
||||
`defgroup', `defvar'.
|
||||
`defgroup', `defvar', `defface'.
|
||||
|
||||
Please send improvements and fixes to the maintainer."
|
||||
:type 'regexp
|
||||
|
|
@ -202,7 +202,7 @@ If VARIABLE-P is nil, `find-function-regexp' is used, otherwise
|
|||
(re-search-forward
|
||||
(concat "^([^ ]+" find-function-space-re "['(]"
|
||||
(regexp-quote (symbol-name symbol))
|
||||
"\\>")
|
||||
"\\_>")
|
||||
nil t))
|
||||
(progn
|
||||
(beginning-of-line)
|
||||
|
|
|
|||
|
|
@ -31,36 +31,6 @@
|
|||
|
||||
(defalias 'current-time-seconds 'current-time)
|
||||
|
||||
;; In case cl-map-keymap is an alias for map-keymap, avoid circular calls.
|
||||
(fset 'cl-map-keymap (indirect-function 'cl-map-keymap))
|
||||
|
||||
(defun map-keymap (function keymap &optional sort-first)
|
||||
"Call FUNCTION for every binding in KEYMAP.
|
||||
This does not include bindings inherited from a parent keymap.
|
||||
FUNCTION receives two arguments each time it is called:
|
||||
the character (more generally, the event type) that is bound,
|
||||
and the binding it has.
|
||||
|
||||
Note that passing the event type directly to `define-key' does not work
|
||||
in Emacs 19. We do not emulate that particular feature of Lucid Emacs.
|
||||
If your code does that, modify it to make a vector containing the event
|
||||
type that you get. That will work in both versions of Emacs."
|
||||
(if sort-first
|
||||
(let (list)
|
||||
(cl-map-keymap (lambda (a b) (push (cons a b) list))
|
||||
keymap)
|
||||
(setq list (sort list
|
||||
(lambda (a b)
|
||||
(setq a (car a) b (car b))
|
||||
(if (integerp a)
|
||||
(if (integerp b) (< a b)
|
||||
t)
|
||||
(if (integerp b) t
|
||||
(string< a b))))))
|
||||
(dolist (p list)
|
||||
(funcall function (car p) (cdr p))))
|
||||
(cl-map-keymap function keymap)))
|
||||
|
||||
(defun read-number (prompt &optional integers-only)
|
||||
"Read a number from the minibuffer.
|
||||
Keep reentering the minibuffer until we get suitable input.
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue