annotate lisp/emacs-lisp/cl-compat.el @ 98452:3984a4da51ca

*** empty log message ***
author Adrian Robert <Adrian.B.Robert@gmail.com>
date Wed, 01 Oct 2008 17:15:16 +0000
parents be35d9783436
children a9dc0e7c3f2b
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
13337
84acc3adcd63 Comment change.
Richard M. Stallman <rms@gnu.org>
parents: 12244
diff changeset
1 ;;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility)
4355
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
2
74466
1d4b1a32fd66 Update copyright years.
Glenn Morris <rgm@gnu.org>
parents: 68648
diff changeset
3 ;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005,
79704
78ee6fae0e41 Add 2008 to copyright years.
Glenn Morris <rgm@gnu.org>
parents: 78217
diff changeset
4 ;; 2006, 2007, 2008 Free Software Foundation, Inc.
4355
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
5
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
6 ;; Author: Dave Gillespie <daveg@synaptics.com>
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
7 ;; Version: 2.02
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
8 ;; Keywords: extensions
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
9
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
10 ;; This file is part of GNU Emacs.
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
11
94655
90a2847062be Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents: 87649
diff changeset
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
4355
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
13 ;; it under the terms of the GNU General Public License as published by
94655
90a2847062be Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents: 87649
diff changeset
14 ;; the Free Software Foundation, either version 3 of the License, or
90a2847062be Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents: 87649
diff changeset
15 ;; (at your option) any later version.
4355
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
16
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
17 ;; GNU Emacs is distributed in the hope that it will be useful,
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
20 ;; GNU General Public License for more details.
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
21
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
22 ;; You should have received a copy of the GNU General Public License
94655
90a2847062be Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents: 87649
diff changeset
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
4355
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
24
7942
bc5dccc5375f Comment change.
Richard M. Stallman <rms@gnu.org>
parents: 4355
diff changeset
25 ;;; Commentary:
4355
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
26
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
27 ;; These are extensions to Emacs Lisp that provide a degree of
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
28 ;; Common Lisp compatibility, beyond what is already built-in
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
29 ;; in Emacs Lisp.
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
30 ;;
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
31 ;; This package was written by Dave Gillespie; it is a complete
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
32 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
33 ;;
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
34 ;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19.
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
35 ;;
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
36 ;; Bug reports, comments, and suggestions are welcome!
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
37
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
38 ;; This file contains emulations of internal routines of the older
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
39 ;; CL package which users may have called directly from their code.
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
40 ;; Use (require 'cl-compat) to get these routines.
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
41
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
42 ;; See cl.el for Change Log.
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
43
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
44
7942
bc5dccc5375f Comment change.
Richard M. Stallman <rms@gnu.org>
parents: 4355
diff changeset
45 ;;; Code:
4355
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
46
96711
be35d9783436 Simply require 'cl (silences spurious warnings).
Glenn Morris <rgm@gnu.org>
parents: 94655
diff changeset
47 ;; This used to be:
be35d9783436 Simply require 'cl (silences spurious warnings).
Glenn Morris <rgm@gnu.org>
parents: 94655
diff changeset
48 ;; (or (featurep 'cl) (require 'cl))
be35d9783436 Simply require 'cl (silences spurious warnings).
Glenn Morris <rgm@gnu.org>
parents: 94655
diff changeset
49 ;; which just has the effect of fooling the byte-compiler into not
be35d9783436 Simply require 'cl (silences spurious warnings).
Glenn Morris <rgm@gnu.org>
parents: 94655
diff changeset
50 ;; loading cl when compiling. However, that leads to some bogus
be35d9783436 Simply require 'cl (silences spurious warnings).
Glenn Morris <rgm@gnu.org>
parents: 94655
diff changeset
51 ;; compiler warnings. Loading cl when compiling cannot do any harm,
be35d9783436 Simply require 'cl (silences spurious warnings).
Glenn Morris <rgm@gnu.org>
parents: 94655
diff changeset
52 ;; because for a long time bootstrap-emacs contained 'cl, due to being
be35d9783436 Simply require 'cl (silences spurious warnings).
Glenn Morris <rgm@gnu.org>
parents: 94655
diff changeset
53 ;; dumped from uncompiled files that eval-when-compile'd cl. So every
be35d9783436 Simply require 'cl (silences spurious warnings).
Glenn Morris <rgm@gnu.org>
parents: 94655
diff changeset
54 ;; file was compiled with 'cl loaded.
be35d9783436 Simply require 'cl (silences spurious warnings).
Glenn Morris <rgm@gnu.org>
parents: 94655
diff changeset
55 (require 'cl)
4355
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
56
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
57
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
58 ;;; Keyword routines not supported by new package.
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
59
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
60 (defmacro defkeyword (x &optional doc)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
61 (list* 'defconst x (list 'quote x) (and doc (list doc))))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
62
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
63 (defun keyword-of (sym)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
64 (or (keywordp sym) (keywordp (intern (format ":%s" sym)))))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
65
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
66
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
67 ;;; Multiple values. Note that the new package uses a different
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
68 ;;; convention for multiple values. The following definitions
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
69 ;;; emulate the old convention; all function names have been changed
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
70 ;;; by capitalizing the first letter: Values, Multiple-value-*,
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
71 ;;; to avoid conflict with the new-style definitions in cl-macs.
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
72
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
73 (put 'Multiple-value-bind 'lisp-indent-function 2)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
74 (put 'Multiple-value-setq 'lisp-indent-function 2)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
75 (put 'Multiple-value-call 'lisp-indent-function 1)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
76 (put 'Multiple-value-prog1 'lisp-indent-function 1)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
77
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
78 (defvar *mvalues-values* nil)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
79
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
80 (defun Values (&rest val-forms)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
81 (setq *mvalues-values* val-forms)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
82 (car val-forms))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
83
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
84 (defun Values-list (val-forms)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
85 (apply 'values val-forms))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
86
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
87 (defmacro Multiple-value-list (form)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
88 (list 'let* (list '(*mvalues-values* nil) (list '*mvalues-temp* form))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
89 '(or (and (eq *mvalues-temp* (car *mvalues-values*)) *mvalues-values*)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
90 (list *mvalues-temp*))))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
91
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
92 (defmacro Multiple-value-call (function &rest args)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
93 (list 'apply function
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
94 (cons 'append
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
95 (mapcar (function (lambda (x) (list 'Multiple-value-list x)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
96 args))))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
97
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
98 (defmacro Multiple-value-bind (vars form &rest body)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
99 (list* 'multiple-value-bind vars (list 'Multiple-value-list form) body))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
100
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
101 (defmacro Multiple-value-setq (vars form)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
102 (list 'multiple-value-setq vars (list 'Multiple-value-list form)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
103
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
104 (defmacro Multiple-value-prog1 (form &rest body)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
105 (list 'prog1 form (list* 'let '((*mvalues-values* nil)) body)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
106
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
107
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
108 ;;; Routines for parsing keyword arguments.
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
109
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
110 (defun build-klist (arglist keys &optional allow-others)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
111 (let ((res (Multiple-value-call 'mapcar* 'cons (unzip-lists arglist))))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
112 (or allow-others
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
113 (let ((bad (set-difference (mapcar 'car res) keys)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
114 (if bad (error "Bad keywords: %s not in %s" bad keys))))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
115 res))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
116
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
117 (defun extract-from-klist (klist key &optional def)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
118 (let ((res (assq key klist))) (if res (cdr res) def)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
119
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
120 (defun keyword-argument-supplied-p (klist key)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
121 (assq key klist))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
122
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
123 (defun elt-satisfies-test-p (item elt klist)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
124 (let ((test-not (cdr (assq ':test-not klist)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
125 (test (cdr (assq ':test klist)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
126 (key (cdr (assq ':key klist))))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
127 (if key (setq elt (funcall key elt)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
128 (if test-not (not (funcall test-not item elt))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
129 (funcall (or test 'eql) item elt))))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
130
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
131
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
132 ;;; Rounding functions with old-style multiple value returns.
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
133
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
134 (defun cl-floor (a &optional b) (Values-list (floor* a b)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
135 (defun cl-ceiling (a &optional b) (Values-list (ceiling* a b)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
136 (defun cl-round (a &optional b) (Values-list (round* a b)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
137 (defun cl-truncate (a &optional b) (Values-list (truncate* a b)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
138
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
139 (defun safe-idiv (a b)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
140 (let* ((q (/ (abs a) (abs b)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
141 (s (* (signum a) (signum b))))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
142 (Values q (- a (* s q b)) s)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
143
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
144
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
145 ;; Internal routines.
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
146
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
147 (defun pair-with-newsyms (oldforms)
58254
e64002f85cf6 (pair-with-newsyms): Use make-symbol.
Stefan Monnier <monnier@iro.umontreal.ca>
parents: 52401
diff changeset
148 (let ((newsyms (mapcar (lambda (x) (make-symbol "--cl-var--")) oldforms)))
4355
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
149 (Values (mapcar* 'list newsyms oldforms) newsyms)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
150
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
151 (defun zip-lists (evens odds)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
152 (mapcan 'list evens odds))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
153
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
154 (defun unzip-lists (list)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
155 (let ((e nil) (o nil))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
156 (while list
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
157 (setq e (cons (car list) e) o (cons (cadr list) o) list (cddr list)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
158 (Values (nreverse e) (nreverse o))))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
159
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
160 (defun reassemble-argslists (list)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
161 (let ((n (apply 'min (mapcar 'length list))) (res nil))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
162 (while (>= (setq n (1- n)) 0)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
163 (setq res (cons (mapcar (function (lambda (x) (elt x n))) list) res)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
164 res))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
165
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
166 (defun duplicate-symbols-p (list)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
167 (let ((res nil))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
168 (while list
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
169 (if (memq (car list) (cdr list)) (setq res (cons (car list) res)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
170 (setq list (cdr list)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
171 res))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
172
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
173
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
174 ;;; Setf internals.
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
175
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
176 (defun setnth (n list x)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
177 (setcar (nthcdr n list) x))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
178
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
179 (defun setnthcdr (n list x)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
180 (setcdr (nthcdr (1- n) list) x))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
181
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
182 (defun setelt (seq n x)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
183 (if (consp seq) (setcar (nthcdr n seq) x) (aset seq n x)))
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
184
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
185
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
186 ;;; Functions omitted: case-clausify, check-do-stepforms, check-do-endforms,
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
187 ;;; extract-do-inits, extract-do[*]-steps, select-stepping-forms,
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
188 ;;; elt-satisfies-if[-not]-p, with-keyword-args, mv-bind-clausify,
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
189 ;;; all names with embedded `$'.
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
190
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
191
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
192 (provide 'cl-compat)
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
193
85728
2797206f47b8 Add a local variables section, and set
Glenn Morris <rgm@gnu.org>
parents: 78217
diff changeset
194 ;; Local variables:
2797206f47b8 Add a local variables section, and set
Glenn Morris <rgm@gnu.org>
parents: 78217
diff changeset
195 ;; byte-compile-warnings: (not cl-functions)
2797206f47b8 Add a local variables section, and set
Glenn Morris <rgm@gnu.org>
parents: 78217
diff changeset
196 ;; End:
2797206f47b8 Add a local variables section, and set
Glenn Morris <rgm@gnu.org>
parents: 78217
diff changeset
197
58254
e64002f85cf6 (pair-with-newsyms): Use make-symbol.
Stefan Monnier <monnier@iro.umontreal.ca>
parents: 52401
diff changeset
198 ;; arch-tag: 9996bb4f-aaf5-4592-b436-bf64759a3163
4355
691a28818487 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
199 ;;; cl-compat.el ends here