Mercurial > emacs
annotate lisp/=cl.el @ 32547:946f66d4b38b
(msdos-handle-reverse-video): Don't remove
reverse from the frame parameters, and don't invert foreground and
background colors.
author | Eli Zaretskii <eliz@gnu.org> |
---|---|
date | Mon, 16 Oct 2000 19:17:35 +0000 |
parents | 507f64624555 |
children |
rev | line source |
---|---|
2229
bd3c525fa6fc
Added standard library headers.
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2000
diff
changeset
|
1 ;;; cl.el --- Common-Lisp extensions for GNU Emacs Lisp. |
bd3c525fa6fc
Added standard library headers.
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2000
diff
changeset
|
2 |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3 ;; Copyright (C) 1987, 1988, 1989, 1992 Free Software Foundation, Inc. |
846
20674ae6bf52
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
798
diff
changeset
|
4 |
798
b7932f859d4e
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
662
diff
changeset
|
5 ;; Author: Cesar Quiroz <quiroz@cs.rochester.edu> |
b7932f859d4e
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
662
diff
changeset
|
6 ;; Keywords: extensions |
b7932f859d4e
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
662
diff
changeset
|
7 |
1861
b5c86d0608ac
* cl.el (cl-version): Mark as no longer in beta test.
Jim Blandy <jimb@redhat.com>
parents:
1553
diff
changeset
|
8 (defvar cl-version "3.0 07-February-1993") |
798
b7932f859d4e
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
662
diff
changeset
|
9 |
188 | 10 ;; This file is part of GNU Emacs. |
11 | |
12 ;; GNU Emacs is distributed in the hope that it will be useful, | |
13 ;; but WITHOUT ANY WARRANTY. No author or distributor | |
14 ;; accepts responsibility to anyone for the consequences of using it | |
15 ;; or for whether it serves any particular purpose or works at all, | |
16 ;; unless he says so in writing. Refer to the GNU Emacs General Public | |
17 ;; License for full details. | |
18 | |
19 ;; Everyone is granted permission to copy, modify and redistribute | |
20 ;; GNU Emacs, but only under the conditions described in the | |
21 ;; GNU Emacs General Public License. A copy of this license is | |
22 ;; supposed to have been given to you along with GNU Emacs so you | |
23 ;; can know your rights and responsibilities. It should be in a | |
24 ;; file named COPYING. Among other things, the copyright notice | |
25 ;; and this notice must be preserved on all copies. | |
26 | |
2229
bd3c525fa6fc
Added standard library headers.
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2000
diff
changeset
|
27 ;;; Commentary: |
bd3c525fa6fc
Added standard library headers.
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2000
diff
changeset
|
28 |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
29 ;;; Notes from Rob Austein on his mods |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
30 ;; yaya:/usr/u/sra/cl/cl.el, 5-May-1991 16:01:34, sra |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
31 ;; |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
32 ;; Slightly hacked copy of cl.el 2.0 beta 27. |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
33 ;; |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
34 ;; Various minor performance improvements: |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
35 ;; a) Don't use MAPCAR when we're going to discard its results. |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
36 ;; b) Make various macros a little more clever about optimizing |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
37 ;; generated code in common cases. |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
38 ;; c) Fix DEFSETF to expand to the right code at compile-time. |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
39 ;; d) Make various macros cleverer about generating reasonable |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
40 ;; code when compiled, particularly forms like DEFSTRUCT which |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
41 ;; are usually used at top-level and thus are only compiled if |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
42 ;; you use Hallvard Furuseth's hacked bytecomp.el. |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
43 ;; |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
44 ;; New features: GETF, REMF, and REMPROP. |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
45 ;; |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
46 ;; Notes: |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
47 ;; 1) I'm sceptical about the FBOUNDP checks in SETF. Why should |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
48 ;; the SETF expansion fail because the SETF method isn't defined |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
49 ;; at compile time? Lisp is going to check for a binding at run-time |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
50 ;; anyway, so maybe we should just assume the user's right here. |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
51 |
188 | 52 ;;;; These are extensions to Emacs Lisp that provide some form of |
53 ;;;; Common Lisp compatibility, beyond what is already built-in | |
54 ;;;; in Emacs Lisp. | |
55 ;;;; | |
56 ;;;; When developing them, I had the code spread among several files. | |
57 ;;;; This file 'cl.el' is a concatenation of those original files, | |
58 ;;;; minus some declarations that became redundant. The marks between | |
59 ;;;; the original files can be found easily, as they are lines that | |
60 ;;;; begin with four semicolons (as this does). The names of the | |
61 ;;;; original parts follow the four semicolons in uppercase, those | |
62 ;;;; names are GLOBAL, SYMBOLS, LISTS, SEQUENCES, CONDITIONALS, | |
63 ;;;; ITERATIONS, MULTIPLE VALUES, ARITH, SETF and DEFSTRUCT. If you | |
64 ;;;; add functions to this file, you might want to put them in a place | |
65 ;;;; that is compatible with the division above (or invent your own | |
66 ;;;; categories). | |
67 ;;;; | |
68 ;;;; To compile this file, make sure you load it first. This is | |
69 ;;;; because many things are implemented as macros and now that all | |
70 ;;;; the files are concatenated together one cannot ensure that | |
71 ;;;; declaration always precedes use. | |
72 ;;;; | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
73 ;;;; Bug reports, suggestions and comments, |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
74 ;;;; to quiroz@cs.rochester.edu |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
75 |
188 | 76 |
77 ;;;; GLOBAL | |
78 ;;;; This file provides utilities and declarations that are global | |
79 ;;;; to Common Lisp and so might be used by more than one of the | |
80 ;;;; other libraries. Especially, I intend to keep here some | |
81 ;;;; utilities that help parsing/destructuring some difficult calls. | |
82 ;;;; | |
83 ;;;; | |
84 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 | |
85 ;;;; (quiroz@cs.rochester.edu) | |
86 | |
87 ;;; Too many pieces of the rest of this package use psetq. So it is unwise to | |
88 ;;; use here anything but plain Emacs Lisp! There is a neater recursive form | |
89 ;;; for the algorithm that deals with the bodies. | |
90 | |
798
b7932f859d4e
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
662
diff
changeset
|
91 ;;; Code: |
b7932f859d4e
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
662
diff
changeset
|
92 |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
93 ;;; This version is due to Hallvard Furuseth (hallvard@ifi.uio.no, 6 Jul 91) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
94 (defmacro psetq (&rest args) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
95 "(psetq {VARIABLE VALUE}...): In parallel, set each VARIABLE to its VALUE. |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
96 All the VALUEs are evaluated, and then all the VARIABLEs are set. |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
97 Aside from order of evaluation, this is the same as `setq'." |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
98 ;; check there is a reasonable number of forms |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
99 (if (/= (% (length args) 2) 0) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
100 (error "Odd number of arguments to `psetq'")) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
101 (setq args (copy-sequence args)) ;for safety below |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
102 (prog1 (cons 'setq args) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
103 (while (progn (if (not (symbolp (car args))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
104 (error "`psetq' expected a symbol, found '%s'." |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
105 (prin1-to-string (car args)))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
106 (cdr (cdr args))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
107 (setcdr args (list (list 'prog1 (nth 1 args) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
108 (cons 'setq |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
109 (setq args (cdr (cdr args)))))))))) |
188 | 110 |
111 ;;; utilities | |
112 ;;; | |
113 ;;; pair-with-newsyms takes a list and returns a list of lists of the | |
114 ;;; form (newsym form), such that a let* can then bind the evaluation | |
115 ;;; of the forms to the newsyms. The idea is to guarantee correct | |
116 ;;; order of evaluation of the subforms of a setf. It also returns a | |
117 ;;; list of the newsyms generated, in the corresponding order. | |
118 | |
119 (defun pair-with-newsyms (oldforms) | |
120 "PAIR-WITH-NEWSYMS OLDFORMS | |
121 The top-level components of the list oldforms are paired with fresh | |
122 symbols, the pairings list and the newsyms list are returned." | |
123 (do ((ptr oldforms (cdr ptr)) | |
124 (bindings '()) | |
125 (newsyms '())) | |
126 ((endp ptr) (values (nreverse bindings) (nreverse newsyms))) | |
127 (let ((newsym (gentemp))) | |
128 (setq bindings (cons (list newsym (car ptr)) bindings)) | |
129 (setq newsyms (cons newsym newsyms))))) | |
130 | |
131 (defun zip-lists (evens odds) | |
132 "Merge two lists EVENS and ODDS, taking elts from each list alternatingly. | |
133 EVENS and ODDS are two lists. ZIP-LISTS constructs a new list, whose | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
134 even numbered elements (0,2,...) come from EVENS and whose odd |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
135 numbered elements (1,3,...) come from ODDS. |
188 | 136 The construction stops when the shorter list is exhausted." |
137 (do* ((p0 evens (cdr p0)) | |
138 (p1 odds (cdr p1)) | |
139 (even (car p0) (car p0)) | |
140 (odd (car p1) (car p1)) | |
141 (result '())) | |
142 ((or (endp p0) (endp p1)) | |
143 (nreverse result)) | |
144 (setq result | |
145 (cons odd (cons even result))))) | |
146 | |
147 (defun unzip-list (list) | |
148 "Extract even and odd elements of LIST into two separate lists. | |
149 The argument LIST is separated in two strands, the even and the odd | |
150 numbered elements. Numbering starts with 0, so the first element | |
151 belongs in EVENS. No check is made that there is an even number of | |
152 elements to start with." | |
153 (do* ((ptr list (cddr ptr)) | |
154 (this (car ptr) (car ptr)) | |
155 (next (cadr ptr) (cadr ptr)) | |
156 (evens '()) | |
157 (odds '())) | |
158 ((endp ptr) | |
159 (values (nreverse evens) (nreverse odds))) | |
160 (setq evens (cons this evens)) | |
161 (setq odds (cons next odds)))) | |
162 | |
163 (defun reassemble-argslists (argslists) | |
164 "(reassemble-argslists ARGSLISTS) => a list of lists | |
165 ARGSLISTS is a list of sequences. Return a list of lists, the first | |
166 sublist being all the entries coming from ELT 0 of the original | |
167 sublists, the next those coming from ELT 1 and so on, until the | |
168 shortest list is exhausted." | |
169 (let* ((minlen (apply 'min (mapcar 'length argslists))) | |
170 (result '())) | |
171 (dotimes (i minlen (nreverse result)) | |
172 ;; capture all the elements at index i | |
173 (setq result | |
174 (cons (mapcar (function (lambda (sublist) (elt sublist i))) | |
175 argslists) | |
176 result))))) | |
177 | |
178 | |
179 ;;; Checking that a list of symbols contains no duplicates is a common | |
180 ;;; task when checking the legality of some macros. The check for 'eq | |
181 ;;; pairs can be too expensive, as it is quadratic on the length of | |
182 ;;; the list. I use a 4-pass, linear, counting approach. It surely | |
183 ;;; loses on small lists (less than 5 elements?), but should win for | |
184 ;;; larger lists. The fourth pass could be eliminated. | |
185 ;;; 10 dec 1986. Emacs Lisp has no REMPROP, so I just eliminated the | |
186 ;;; 4th pass. | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
187 ;;; |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
188 ;;; [22 April 1991, sra] REMPROP now in library, so restored 4th pass. |
188 | 189 (defun duplicate-symbols-p (list) |
190 "Find all symbols appearing more than once in LIST. | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
191 Return a list of all such duplicates; `nil' if there are no duplicates." |
188 | 192 (let ((duplicates '()) ;result built here |
193 (propname (gensym)) ;we use a fresh property | |
194 ) | |
195 ;; check validity | |
196 (unless (and (listp list) | |
197 (every 'symbolp list)) | |
198 (error "a list of symbols is needed")) | |
199 ;; pass 1: mark | |
200 (dolist (x list) | |
201 (put x propname 0)) | |
202 ;; pass 2: count | |
203 (dolist (x list) | |
204 (put x propname (1+ (get x propname)))) | |
205 ;; pass 3: collect | |
206 (dolist (x list) | |
207 (if (> (get x propname) 1) | |
208 (setq duplicates (cons x duplicates)))) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
209 ;; pass 4: unmark. |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
210 (dolist (x list) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
211 (remprop x propname)) |
188 | 212 ;; return result |
213 duplicates)) | |
214 | |
215 ;;;; end of cl-global.el | |
216 | |
217 ;;;; SYMBOLS | |
218 ;;;; This file provides the gentemp function, which generates fresh | |
219 ;;;; symbols, plus some other minor Common Lisp symbol tools. | |
220 ;;;; | |
221 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 | |
222 ;;;; (quiroz@cs.rochester.edu) | |
223 | |
224 ;;; Keywords. There are no packages in Emacs Lisp, so this is only a | |
225 ;;; kludge around to let things be "as if" a keyword package was around. | |
226 | |
227 (defmacro defkeyword (x &optional docstring) | |
228 "Make symbol X a keyword (symbol whose value is itself). | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
229 Optional second argument is a documentation string for it." |
188 | 230 (cond ((symbolp x) |
231 (list 'defconst x (list 'quote x) docstring)) | |
232 (t | |
233 (error "`%s' is not a symbol" (prin1-to-string x))))) | |
234 | |
235 (defun keywordp (sym) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
236 "t if SYM is a keyword." |
188 | 237 (if (and (symbolp sym) (char-equal (aref (symbol-name sym) 0) ?\:)) |
238 ;; looks like one, make sure value is right | |
239 (set sym sym) | |
240 nil)) | |
241 | |
242 (defun keyword-of (sym) | |
243 "Return a keyword that is naturally associated with symbol SYM. | |
244 If SYM is keyword, the value is SYM. | |
245 Otherwise it is a keyword whose name is `:' followed by SYM's name." | |
246 (cond ((keywordp sym) | |
247 sym) | |
248 ((symbolp sym) | |
249 (let ((newsym (intern (concat ":" (symbol-name sym))))) | |
250 (set newsym newsym))) | |
251 (t | |
252 (error "expected a symbol, not `%s'" (prin1-to-string sym))))) | |
253 | |
254 ;;; Temporary symbols. | |
255 ;;; | |
256 | |
257 (defvar *gentemp-index* 0 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
258 "Integer used by gentemp to produce new names.") |
188 | 259 |
260 (defvar *gentemp-prefix* "T$$_" | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
261 "Names generated by gentemp begin with this string by default.") |
188 | 262 |
263 (defun gentemp (&optional prefix oblist) | |
264 "Generate a fresh interned symbol. | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
265 There are 2 optional arguments, PREFIX and OBLIST. PREFIX is the |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
266 string that begins the new name, OBLIST is the obarray used to search for |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
267 old names. The defaults are just right, YOU SHOULD NEVER NEED THESE |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
268 ARGUMENTS IN YOUR OWN CODE." |
188 | 269 (if (null prefix) |
270 (setq prefix *gentemp-prefix*)) | |
271 (if (null oblist) | |
272 (setq oblist obarray)) ;default for the intern functions | |
273 (let ((newsymbol nil) | |
274 (newname)) | |
275 (while (not newsymbol) | |
276 (setq newname (concat prefix *gentemp-index*)) | |
277 (setq *gentemp-index* (+ *gentemp-index* 1)) | |
278 (if (not (intern-soft newname oblist)) | |
279 (setq newsymbol (intern newname oblist)))) | |
280 newsymbol)) | |
281 | |
282 (defvar *gensym-index* 0 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
283 "Integer used by gensym to produce new names.") |
188 | 284 |
285 (defvar *gensym-prefix* "G$$_" | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
286 "Names generated by gensym begin with this string by default.") |
188 | 287 |
288 (defun gensym (&optional prefix) | |
289 "Generate a fresh uninterned symbol. | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
290 There is an optional argument, PREFIX. PREFIX is the |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
291 string that begins the new name. Most people take just the default, |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
292 except when debugging needs suggest otherwise." |
188 | 293 (if (null prefix) |
294 (setq prefix *gensym-prefix*)) | |
295 (let ((newsymbol nil) | |
296 (newname "")) | |
297 (while (not newsymbol) | |
298 (setq newname (concat prefix *gensym-index*)) | |
299 (setq *gensym-index* (+ *gensym-index* 1)) | |
300 (if (not (intern-soft newname)) | |
301 (setq newsymbol (make-symbol newname)))) | |
302 newsymbol)) | |
303 | |
304 ;;;; end of cl-symbols.el | |
305 | |
306 ;;;; CONDITIONALS | |
307 ;;;; This file provides some of the conditional constructs of | |
308 ;;;; Common Lisp. Total compatibility is again impossible, as the | |
309 ;;;; 'if' form is different in both languages, so only a good | |
310 ;;;; approximation is desired. | |
311 ;;;; | |
312 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 | |
313 ;;;; (quiroz@cs.rochester.edu) | |
314 | |
315 ;;; indentation info | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
316 (put 'case 'lisp-indent-hook 1) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
317 (put 'ecase 'lisp-indent-hook 1) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
318 (put 'when 'lisp-indent-hook 1) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
319 (put 'unless 'lisp-indent-hook 1) |
188 | 320 |
321 ;;; WHEN and UNLESS | |
322 ;;; These two forms are simplified ifs, with a single branch. | |
323 | |
324 (defmacro when (condition &rest body) | |
325 "(when CONDITION . BODY) => evaluate BODY if CONDITION is true." | |
326 (list* 'if (list 'not condition) '() body)) | |
327 | |
328 (defmacro unless (condition &rest body) | |
329 "(unless CONDITION . BODY) => evaluate BODY if CONDITION is false." | |
330 (list* 'if condition '() body)) | |
331 | |
332 ;;; CASE and ECASE | |
333 ;;; CASE selects among several clauses, based on the value (evaluated) | |
334 ;;; of a expression and a list of (unevaluated) key values. ECASE is | |
335 ;;; the same, but signals an error if no clause is activated. | |
336 | |
337 (defmacro case (expr &rest cases) | |
338 "(case EXPR . CASES) => evals EXPR, chooses from CASES on that value. | |
339 EXPR -> any form | |
340 CASES -> list of clauses, non empty | |
341 CLAUSE -> HEAD . BODY | |
342 HEAD -> t = catch all, must be last clause | |
343 -> otherwise = same as t | |
344 -> nil = illegal | |
345 -> atom = activated if (eql EXPR HEAD) | |
346 -> list of atoms = activated if (memq EXPR HEAD) | |
347 BODY -> list of forms, implicit PROGN is built around it. | |
348 EXPR is evaluated only once." | |
349 (let* ((newsym (gentemp)) | |
350 (clauses (case-clausify cases newsym))) | |
351 ;; convert case into a cond inside a let | |
352 (list 'let | |
353 (list (list newsym expr)) | |
354 (list* 'cond (nreverse clauses))))) | |
355 | |
356 (defmacro ecase (expr &rest cases) | |
357 "(ecase EXPR . CASES) => like `case', but error if no case fits. | |
358 `t'-clauses are not allowed." | |
359 (let* ((newsym (gentemp)) | |
360 (clauses (case-clausify cases newsym))) | |
361 ;; check that no 't clause is present. | |
362 ;; case-clausify would put one such at the beginning of clauses | |
363 (if (eq (caar clauses) t) | |
364 (error "no clause-head should be `t' or `otherwise' for `ecase'")) | |
365 ;; insert error-catching clause | |
366 (setq clauses | |
367 (cons | |
368 (list 't (list 'error | |
369 "ecase on %s = %s failed to take any branch" | |
370 (list 'quote expr) | |
371 (list 'prin1-to-string newsym))) | |
372 clauses)) | |
373 ;; generate code as usual | |
374 (list 'let | |
375 (list (list newsym expr)) | |
376 (list* 'cond (nreverse clauses))))) | |
377 | |
378 | |
379 (defun case-clausify (cases newsym) | |
380 "CASE-CLAUSIFY CASES NEWSYM => clauses for a 'cond' | |
381 Converts the CASES of a [e]case macro into cond clauses to be | |
382 evaluated inside a let that binds NEWSYM. Returns the clauses in | |
383 reverse order." | |
384 (do* ((currentpos cases (cdr currentpos)) | |
385 (nextpos (cdr cases) (cdr nextpos)) | |
386 (curclause (car cases) (car currentpos)) | |
387 (result '())) | |
388 ((endp currentpos) result) | |
389 (let ((head (car curclause)) | |
390 (body (cdr curclause))) | |
391 ;; construct a cond-clause according to the head | |
392 (cond ((null head) | |
393 (error "case clauses cannot have null heads: `%s'" | |
394 (prin1-to-string curclause))) | |
395 ((or (eq head 't) | |
396 (eq head 'otherwise)) | |
397 ;; check it is the last clause | |
398 (if (not (endp nextpos)) | |
399 (error "clause with `t' or `otherwise' head must be last")) | |
400 ;; accept this clause as a 't' for cond | |
401 (setq result (cons (cons 't body) result))) | |
402 ((atom head) | |
403 (setq result | |
404 (cons (cons (list 'eql newsym (list 'quote head)) body) | |
405 result))) | |
406 ((listp head) | |
407 (setq result | |
408 (cons (cons (list 'memq newsym (list 'quote head)) body) | |
409 result))) | |
410 (t | |
411 ;; catch-all for this parser | |
412 (error "don't know how to parse case clause `%s'" | |
413 (prin1-to-string head))))))) | |
414 | |
415 ;;;; end of cl-conditionals.el | |
416 | |
417 ;;;; ITERATIONS | |
418 ;;;; This file provides simple iterative macros (a la Common Lisp) | |
419 ;;;; constructed on the basis of let, let* and while, which are the | |
420 ;;;; primitive binding/iteration constructs of Emacs Lisp | |
421 ;;;; | |
422 ;;;; The Common Lisp iterations use to have a block named nil | |
423 ;;;; wrapped around them, and allow declarations at the beginning | |
424 ;;;; of their bodies and you can return a value using (return ...). | |
425 ;;;; Nothing of the sort exists in Emacs Lisp, so I haven't tried | |
426 ;;;; to imitate these behaviors. | |
427 ;;;; | |
428 ;;;; Other than the above, the semantics of Common Lisp are | |
429 ;;;; correctly reproduced to the extent this was reasonable. | |
430 ;;;; | |
431 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 | |
432 ;;;; (quiroz@cs.rochester.edu) | |
433 | |
434 ;;; some lisp-indentation information | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
435 (put 'do 'lisp-indent-hook 2) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
436 (put 'do* 'lisp-indent-hook 2) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
437 (put 'dolist 'lisp-indent-hook 1) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
438 (put 'dotimes 'lisp-indent-hook 1) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
439 (put 'do-symbols 'lisp-indent-hook 1) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
440 (put 'do-all-symbols 'lisp-indent-hook 1) |
188 | 441 |
442 | |
443 (defmacro do (stepforms endforms &rest body) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
444 "(do STEPFORMS ENDFORMS . BODY): Iterate BODY, stepping some local variables. |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
445 STEPFORMS must be a list of symbols or lists. In the second case, the |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
446 lists must start with a symbol and contain up to two more forms. In |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
447 the STEPFORMS, a symbol is the same as a (symbol). The other 2 forms |
188 | 448 are the initial value (def. NIL) and the form to step (def. itself). |
449 The values used by initialization and stepping are computed in parallel. | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
450 The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
451 evaluates to true in any iteration, ENDBODY is evaluated and the last |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
452 form in it is returned. |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
453 The BODY (which may be empty) is evaluated at every iteration, with |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
454 the symbols of the STEPFORMS bound to the initial or stepped values." |
188 | 455 ;; check the syntax of the macro |
456 (and (check-do-stepforms stepforms) | |
457 (check-do-endforms endforms)) | |
458 ;; construct emacs-lisp equivalent | |
459 (let ((initlist (extract-do-inits stepforms)) | |
460 (steplist (extract-do-steps stepforms)) | |
461 (endcond (car endforms)) | |
462 (endbody (cdr endforms))) | |
463 (cons 'let (cons initlist | |
464 (cons (cons 'while (cons (list 'not endcond) | |
465 (append body steplist))) | |
466 (append endbody)))))) | |
467 | |
468 | |
469 (defmacro do* (stepforms endforms &rest body) | |
470 "`do*' is to `do' as `let*' is to `let'. | |
471 STEPFORMS must be a list of symbols or lists. In the second case, the | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
472 lists must start with a symbol and contain up to two more forms. In |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
473 the STEPFORMS, a symbol is the same as a (symbol). The other 2 forms |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
474 are the initial value (def. NIL) and the form to step (def. itself). |
188 | 475 Initializations and steppings are done in the sequence they are written. |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
476 The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
477 evaluates to true in any iteration, ENDBODY is evaluated and the last |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
478 form in it is returned. |
188 | 479 The BODY (which may be empty) is evaluated at every iteration, with |
480 the symbols of the STEPFORMS bound to the initial or stepped values." | |
481 ;; check the syntax of the macro | |
482 (and (check-do-stepforms stepforms) | |
483 (check-do-endforms endforms)) | |
484 ;; construct emacs-lisp equivalent | |
485 (let ((initlist (extract-do-inits stepforms)) | |
486 (steplist (extract-do*-steps stepforms)) | |
487 (endcond (car endforms)) | |
488 (endbody (cdr endforms))) | |
489 (cons 'let* (cons initlist | |
490 (cons (cons 'while (cons (list 'not endcond) | |
491 (append body steplist))) | |
492 (append endbody)))))) | |
493 | |
494 | |
495 ;;; DO and DO* share the syntax checking functions that follow. | |
496 | |
497 (defun check-do-stepforms (forms) | |
498 "True if FORMS is a valid stepforms for the do[*] macro (q.v.)" | |
499 (if (nlistp forms) | |
500 (error "init/step form for do[*] should be a list, not `%s'" | |
501 (prin1-to-string forms)) | |
502 (mapcar | |
503 (function | |
504 (lambda (entry) | |
505 (if (not (or (symbolp entry) | |
506 (and (listp entry) | |
507 (symbolp (car entry)) | |
508 (< (length entry) 4)))) | |
509 (error "init/step must be %s, not `%s'" | |
510 "symbol or (symbol [init [step]])" | |
511 (prin1-to-string entry))))) | |
512 forms))) | |
513 | |
514 (defun check-do-endforms (forms) | |
515 "True if FORMS is a valid endforms for the do[*] macro (q.v.)" | |
516 (if (nlistp forms) | |
517 (error "termination form for do macro should be a list, not `%s'" | |
518 (prin1-to-string forms)))) | |
519 | |
520 (defun extract-do-inits (forms) | |
521 "Returns a list of the initializations (for do) in FORMS | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
522 --a stepforms, see the do macro--. FORMS is assumed syntactically valid." |
188 | 523 (mapcar |
524 (function | |
525 (lambda (entry) | |
526 (cond ((symbolp entry) | |
527 (list entry nil)) | |
528 ((listp entry) | |
529 (list (car entry) (cadr entry)))))) | |
530 forms)) | |
531 | |
532 ;;; There used to be a reason to deal with DO differently than with | |
533 ;;; DO*. The writing of PSETQ has made it largely unnecessary. | |
534 | |
535 (defun extract-do-steps (forms) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
536 "EXTRACT-DO-STEPS FORMS => an s-expr |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
537 FORMS is the stepforms part of a DO macro (q.v.). This function |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
538 constructs an s-expression that does the stepping at the end of an |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
539 iteration." |
188 | 540 (list (cons 'psetq (select-stepping-forms forms)))) |
541 | |
542 (defun extract-do*-steps (forms) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
543 "EXTRACT-DO*-STEPS FORMS => an s-expr |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
544 FORMS is the stepforms part of a DO* macro (q.v.). This function |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
545 constructs an s-expression that does the stepping at the end of an |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
546 iteration." |
188 | 547 (list (cons 'setq (select-stepping-forms forms)))) |
548 | |
549 (defun select-stepping-forms (forms) | |
550 "Separate only the forms that cause stepping." | |
551 (let ((result '()) ;ends up being (... var form ...) | |
552 (ptr forms) ;to traverse the forms | |
553 entry ;to explore each form in turn | |
554 ) | |
555 (while ptr ;(not (endp entry)) might be safer | |
556 (setq entry (car ptr)) | |
557 (cond ((and (listp entry) (= (length entry) 3)) | |
558 (setq result (append ;append in reverse order! | |
559 (list (caddr entry) (car entry)) | |
560 result)))) | |
561 (setq ptr (cdr ptr))) ;step in the list of forms | |
562 (nreverse result))) | |
563 | |
564 ;;; Other iterative constructs | |
565 | |
566 (defmacro dolist (stepform &rest body) | |
567 "(dolist (VAR LIST [RESULTFORM]) . BODY): do BODY for each elt of LIST. | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
568 The RESULTFORM defaults to nil. The VAR is bound to successive |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
569 elements of the value of LIST and remains bound (to the nil value) when the |
188 | 570 RESULTFORM is evaluated." |
571 ;; check sanity | |
572 (cond | |
573 ((nlistp stepform) | |
574 (error "stepform for `dolist' should be (VAR LIST [RESULT]), not `%s'" | |
575 (prin1-to-string stepform))) | |
576 ((not (symbolp (car stepform))) | |
577 (error "first component of stepform should be a symbol, not `%s'" | |
578 (prin1-to-string (car stepform)))) | |
579 ((> (length stepform) 3) | |
580 (error "too many components in stepform `%s'" | |
581 (prin1-to-string stepform)))) | |
582 ;; generate code | |
583 (let* ((var (car stepform)) | |
584 (listform (cadr stepform)) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
585 (resultform (caddr stepform)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
586 (listsym (gentemp))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
587 (nconc |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
588 (list 'let (list var (list listsym listform)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
589 (nconc |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
590 (list 'while listsym |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
591 (list 'setq |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
592 var (list 'car listsym) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
593 listsym (list 'cdr listsym))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
594 body)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
595 (and resultform |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
596 (cons (list 'setq var nil) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
597 (list resultform)))))) |
188 | 598 |
599 (defmacro dotimes (stepform &rest body) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
600 "(dotimes (VAR COUNTFORM [RESULTFORM]) . BODY): Repeat BODY, counting in VAR. |
188 | 601 The COUNTFORM should return a positive integer. The VAR is bound to |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
602 successive integers from 0 to COUNTFORM-1 and the BODY is repeated for |
188 | 603 each of them. At the end, the RESULTFORM is evaluated and its value |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
604 returned. During this last evaluation, the VAR is still bound, and its |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
605 value is the number of times the iteration occurred. An omitted RESULTFORM |
188 | 606 defaults to nil." |
607 ;; check sanity | |
608 (cond | |
609 ((nlistp stepform) | |
610 (error "stepform for `dotimes' should be (VAR COUNT [RESULT]), not `%s'" | |
611 (prin1-to-string stepform))) | |
612 ((not (symbolp (car stepform))) | |
613 (error "first component of stepform should be a symbol, not `%s'" | |
614 (prin1-to-string (car stepform)))) | |
615 ((> (length stepform) 3) | |
616 (error "too many components in stepform `%s'" | |
617 (prin1-to-string stepform)))) | |
618 ;; generate code | |
619 (let* ((var (car stepform)) | |
620 (countform (cadr stepform)) | |
621 (resultform (caddr stepform)) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
622 (testsym (if (consp countform) (gentemp) countform))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
623 (nconc |
188 | 624 (list |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
625 'let (cons (list var -1) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
626 (and (not (eq countform testsym)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
627 (list (list testsym countform)))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
628 (nconc |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
629 (list 'while (list '< (list 'setq var (list '1+ var)) testsym)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
630 body)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
631 (and resultform (list resultform))))) |
188 | 632 |
633 (defmacro do-symbols (stepform &rest body) | |
634 "(do_symbols (VAR [OBARRAY [RESULTFORM]]) . BODY) | |
635 The VAR is bound to each of the symbols in OBARRAY (def. obarray) and | |
636 the BODY is repeatedly performed for each of those bindings. At the | |
637 end, RESULTFORM (def. nil) is evaluated and its value returned. | |
638 During this last evaluation, the VAR is still bound and its value is nil. | |
639 See also the function `mapatoms'." | |
640 ;; check sanity | |
641 (cond | |
642 ((nlistp stepform) | |
643 (error "stepform for `do-symbols' should be (VAR OBARRAY [RESULT]), not `%s'" | |
644 (prin1-to-string stepform))) | |
645 ((not (symbolp (car stepform))) | |
646 (error "first component of stepform should be a symbol, not `%s'" | |
647 (prin1-to-string (car stepform)))) | |
648 ((> (length stepform) 3) | |
649 (error "too many components in stepform `%s'" | |
650 (prin1-to-string stepform)))) | |
651 ;; generate code | |
652 (let* ((var (car stepform)) | |
653 (oblist (cadr stepform)) | |
654 (resultform (caddr stepform))) | |
655 (list 'progn | |
656 (list 'mapatoms | |
657 (list 'function | |
658 (cons 'lambda (cons (list var) body))) | |
659 oblist) | |
660 (list 'let | |
661 (list (list var nil)) | |
662 resultform)))) | |
663 | |
664 | |
665 (defmacro do-all-symbols (stepform &rest body) | |
666 "(do-all-symbols (VAR [RESULTFORM]) . BODY) | |
667 Is the same as (do-symbols (VAR obarray RESULTFORM) . BODY)." | |
668 (list* | |
669 'do-symbols | |
670 (list (car stepform) 'obarray (cadr stepform)) | |
671 body)) | |
672 | |
673 (defmacro loop (&rest body) | |
674 "(loop . BODY) repeats BODY indefinitely and does not return. | |
675 Normally BODY uses `throw' or `signal' to cause an exit. | |
676 The forms in BODY should be lists, as non-lists are reserved for new features." | |
677 ;; check that the body doesn't have atomic forms | |
678 (if (nlistp body) | |
679 (error "body of `loop' should be a list of lists or nil") | |
680 ;; ok, it is a list, check for atomic components | |
681 (mapcar | |
682 (function (lambda (component) | |
683 (if (nlistp component) | |
684 (error "components of `loop' should be lists")))) | |
685 body) | |
686 ;; build the infinite loop | |
687 (cons 'while (cons 't body)))) | |
688 | |
689 ;;;; end of cl-iterations.el | |
690 | |
691 ;;;; LISTS | |
692 ;;;; This file provides some of the lists machinery of Common-Lisp | |
693 ;;;; in a way compatible with Emacs Lisp. Especially, see the the | |
694 ;;;; typical c[ad]*r functions. | |
695 ;;;; | |
696 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 | |
697 ;;;; (quiroz@cs.rochester.edu) | |
698 | |
699 ;;; Synonyms for list functions | |
957 | 700 (defsubst first (x) |
188 | 701 "Synonym for `car'" |
702 (car x)) | |
703 | |
957 | 704 (defsubst second (x) |
188 | 705 "Return the second element of the list LIST." |
706 (nth 1 x)) | |
707 | |
957 | 708 (defsubst third (x) |
188 | 709 "Return the third element of the list LIST." |
710 (nth 2 x)) | |
711 | |
957 | 712 (defsubst fourth (x) |
188 | 713 "Return the fourth element of the list LIST." |
714 (nth 3 x)) | |
715 | |
957 | 716 (defsubst fifth (x) |
188 | 717 "Return the fifth element of the list LIST." |
718 (nth 4 x)) | |
719 | |
957 | 720 (defsubst sixth (x) |
188 | 721 "Return the sixth element of the list LIST." |
722 (nth 5 x)) | |
723 | |
957 | 724 (defsubst seventh (x) |
188 | 725 "Return the seventh element of the list LIST." |
726 (nth 6 x)) | |
727 | |
957 | 728 (defsubst eighth (x) |
188 | 729 "Return the eighth element of the list LIST." |
730 (nth 7 x)) | |
731 | |
957 | 732 (defsubst ninth (x) |
188 | 733 "Return the ninth element of the list LIST." |
734 (nth 8 x)) | |
735 | |
957 | 736 (defsubst tenth (x) |
188 | 737 "Return the tenth element of the list LIST." |
738 (nth 9 x)) | |
739 | |
957 | 740 (defsubst rest (x) |
188 | 741 "Synonym for `cdr'" |
742 (cdr x)) | |
743 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
744 (defsubst endp (x) |
188 | 745 "t if X is nil, nil if X is a cons; error otherwise." |
746 (if (listp x) | |
747 (null x) | |
748 (error "endp received a non-cons, non-null argument `%s'" | |
749 (prin1-to-string x)))) | |
750 | |
751 (defun last (x) | |
752 "Returns the last link in the list LIST." | |
753 (if (nlistp x) | |
754 (error "arg to `last' must be a list")) | |
755 (do ((current-cons x (cdr current-cons)) | |
756 (next-cons (cdr x) (cdr next-cons))) | |
757 ((endp next-cons) current-cons))) | |
758 | |
759 (defun list-length (x) ;taken from CLtL sect. 15.2 | |
760 "Returns the length of a non-circular list, or `nil' for a circular one." | |
761 (do ((n 0) ;counter | |
762 (fast x (cddr fast)) ;fast pointer, leaps by 2 | |
763 (slow x (cdr slow)) ;slow pointer, leaps by 1 | |
764 (ready nil)) ;indicates termination | |
765 (ready n) | |
766 (cond ((endp fast) | |
767 (setq ready t)) ;return n | |
768 ((endp (cdr fast)) | |
769 (setq n (+ n 1)) | |
770 (setq ready t)) ;return n+1 | |
771 ((and (eq fast slow) (> n 0)) | |
772 (setq n nil) | |
773 (setq ready t)) ;return nil | |
774 (t | |
775 (setq n (+ n 2)))))) ;just advance counter | |
776 | |
777 (defun butlast (list &optional n) | |
778 "Return a new list like LIST but sans the last N elements. | |
779 N defaults to 1. If the list doesn't have N elements, nil is returned." | |
780 (if (null n) (setq n 1)) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
781 (nreverse (nthcdr n (reverse list)))) ;optim. due to macrakis@osf.org |
188 | 782 |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
783 ;;; This version due to Aaron Larson (alarson@src.honeywell.com, 26 Jul 91) |
188 | 784 (defun list* (arg &rest others) |
785 "Return a new list containing the first arguments consed onto the last arg. | |
786 Thus, (list* 1 2 3 '(a b)) returns (1 2 3 a b)." | |
787 (if (null others) | |
788 arg | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
789 (let* ((others (cons arg (copy-sequence others))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
790 (a others)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
791 (while (cdr (cdr a)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
792 (setq a (cdr a))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
793 (setcdr a (car (cdr a))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
794 others))) |
188 | 795 |
796 (defun adjoin (item list) | |
797 "Return a list which contains ITEM but is otherwise like LIST. | |
798 If ITEM occurs in LIST, the value is LIST. Otherwise it is (cons ITEM LIST). | |
799 When comparing ITEM against elements, `eql' is used." | |
800 (if (memq item list) | |
801 list | |
802 (cons item list))) | |
803 | |
804 (defun ldiff (list sublist) | |
805 "Return a new list like LIST but sans SUBLIST. | |
806 SUBLIST must be one of the links in LIST; otherwise the value is LIST itself." | |
807 (do ((result '()) | |
808 (curcons list (cdr curcons))) | |
809 ((or (endp curcons) (eq curcons sublist)) | |
810 (reverse result)) | |
811 (setq result (cons (car curcons) result)))) | |
812 | |
813 ;;; The popular c[ad]*r functions and other list accessors. | |
814 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
815 ;;; To implement this efficiently, a new byte compile handler is used to |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
816 ;;; generate the minimal code, saving one function call. |
922 | 817 |
957 | 818 (defsubst caar (X) |
188 | 819 "Return the car of the car of X." |
820 (car (car X))) | |
821 | |
957 | 822 (defsubst cadr (X) |
188 | 823 "Return the car of the cdr of X." |
824 (car (cdr X))) | |
825 | |
957 | 826 (defsubst cdar (X) |
188 | 827 "Return the cdr of the car of X." |
828 (cdr (car X))) | |
829 | |
957 | 830 (defsubst cddr (X) |
188 | 831 "Return the cdr of the cdr of X." |
832 (cdr (cdr X))) | |
833 | |
957 | 834 (defsubst caaar (X) |
188 | 835 "Return the car of the car of the car of X." |
836 (car (car (car X)))) | |
837 | |
957 | 838 (defsubst caadr (X) |
188 | 839 "Return the car of the car of the cdr of X." |
840 (car (car (cdr X)))) | |
841 | |
957 | 842 (defsubst cadar (X) |
188 | 843 "Return the car of the cdr of the car of X." |
844 (car (cdr (car X)))) | |
845 | |
957 | 846 (defsubst cdaar (X) |
188 | 847 "Return the cdr of the car of the car of X." |
848 (cdr (car (car X)))) | |
849 | |
957 | 850 (defsubst caddr (X) |
188 | 851 "Return the car of the cdr of the cdr of X." |
852 (car (cdr (cdr X)))) | |
853 | |
957 | 854 (defsubst cdadr (X) |
188 | 855 "Return the cdr of the car of the cdr of X." |
856 (cdr (car (cdr X)))) | |
857 | |
957 | 858 (defsubst cddar (X) |
188 | 859 "Return the cdr of the cdr of the car of X." |
860 (cdr (cdr (car X)))) | |
861 | |
957 | 862 (defsubst cdddr (X) |
188 | 863 "Return the cdr of the cdr of the cdr of X." |
864 (cdr (cdr (cdr X)))) | |
865 | |
957 | 866 (defsubst caaaar (X) |
188 | 867 "Return the car of the car of the car of the car of X." |
868 (car (car (car (car X))))) | |
869 | |
957 | 870 (defsubst caaadr (X) |
188 | 871 "Return the car of the car of the car of the cdr of X." |
872 (car (car (car (cdr X))))) | |
873 | |
957 | 874 (defsubst caadar (X) |
188 | 875 "Return the car of the car of the cdr of the car of X." |
876 (car (car (cdr (car X))))) | |
877 | |
957 | 878 (defsubst cadaar (X) |
188 | 879 "Return the car of the cdr of the car of the car of X." |
880 (car (cdr (car (car X))))) | |
881 | |
957 | 882 (defsubst cdaaar (X) |
188 | 883 "Return the cdr of the car of the car of the car of X." |
884 (cdr (car (car (car X))))) | |
885 | |
957 | 886 (defsubst caaddr (X) |
188 | 887 "Return the car of the car of the cdr of the cdr of X." |
888 (car (car (cdr (cdr X))))) | |
889 | |
957 | 890 (defsubst cadadr (X) |
188 | 891 "Return the car of the cdr of the car of the cdr of X." |
892 (car (cdr (car (cdr X))))) | |
893 | |
957 | 894 (defsubst cdaadr (X) |
188 | 895 "Return the cdr of the car of the car of the cdr of X." |
896 (cdr (car (car (cdr X))))) | |
897 | |
957 | 898 (defsubst caddar (X) |
188 | 899 "Return the car of the cdr of the cdr of the car of X." |
900 (car (cdr (cdr (car X))))) | |
901 | |
957 | 902 (defsubst cdadar (X) |
188 | 903 "Return the cdr of the car of the cdr of the car of X." |
904 (cdr (car (cdr (car X))))) | |
905 | |
957 | 906 (defsubst cddaar (X) |
188 | 907 "Return the cdr of the cdr of the car of the car of X." |
908 (cdr (cdr (car (car X))))) | |
909 | |
957 | 910 (defsubst cadddr (X) |
188 | 911 "Return the car of the cdr of the cdr of the cdr of X." |
912 (car (cdr (cdr (cdr X))))) | |
913 | |
957 | 914 (defsubst cddadr (X) |
188 | 915 "Return the cdr of the cdr of the car of the cdr of X." |
916 (cdr (cdr (car (cdr X))))) | |
917 | |
957 | 918 (defsubst cdaddr (X) |
188 | 919 "Return the cdr of the car of the cdr of the cdr of X." |
920 (cdr (car (cdr (cdr X))))) | |
921 | |
957 | 922 (defsubst cdddar (X) |
188 | 923 "Return the cdr of the cdr of the cdr of the car of X." |
924 (cdr (cdr (cdr (car X))))) | |
925 | |
957 | 926 (defsubst cddddr (X) |
188 | 927 "Return the cdr of the cdr of the cdr of the cdr of X." |
928 (cdr (cdr (cdr (cdr X))))) | |
929 | |
930 ;;; some inverses of the accessors are needed for setf purposes | |
931 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
932 (defsubst setnth (n list newval) |
188 | 933 "Set (nth N LIST) to NEWVAL. Returns NEWVAL." |
934 (rplaca (nthcdr n list) newval)) | |
935 | |
936 (defun setnthcdr (n list newval) | |
937 "(setnthcdr N LIST NEWVAL) => NEWVAL | |
938 As a side effect, sets the Nth cdr of LIST to NEWVAL." | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
939 (when (< n 0) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
940 (error "N must be 0 or greater, not %d" n)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
941 (while (> n 0) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
942 (setq list (cdr list) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
943 n (- n 1))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
944 ;; here only if (zerop n) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
945 (rplaca list (car newval)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
946 (rplacd list (cdr newval)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
947 newval) |
188 | 948 |
949 ;;; A-lists machinery | |
950 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
951 (defsubst acons (key item alist) |
188 | 952 "Return a new alist with KEY paired with ITEM; otherwise like ALIST. |
953 Does not copy ALIST." | |
954 (cons (cons key item) alist)) | |
955 | |
956 (defun pairlis (keys data &optional alist) | |
957 "Return a new alist with each elt of KEYS paired with an elt of DATA; | |
958 optional 3rd arg ALIST is nconc'd at the end. KEYS and DATA must | |
959 have the same length." | |
960 (unless (= (length keys) (length data)) | |
961 (error "keys and data should be the same length")) | |
962 (do* ;;collect keys and data in front of alist | |
963 ((kptr keys (cdr kptr)) ;traverses the keys | |
964 (dptr data (cdr dptr)) ;traverses the data | |
965 (key (car kptr) (car kptr)) ;current key | |
966 (item (car dptr) (car dptr)) ;current data item | |
967 (result alist)) | |
968 ((endp kptr) result) | |
969 (setq result (acons key item result)))) | |
970 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
971 ;;;; end of cl-lists.el |
188 | 972 |
973 ;;;; SEQUENCES | |
974 ;;;; Emacs Lisp provides many of the 'sequences' functionality of | |
975 ;;;; Common Lisp. This file provides a few things that were left out. | |
976 ;;;; | |
977 | |
978 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
979 (defkeyword :test "Used to designate positive (selection) tests.") |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
980 (defkeyword :test-not "Used to designate negative (rejection) tests.") |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
981 (defkeyword :key "Used to designate component extractions.") |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
982 (defkeyword :predicate "Used to define matching of sequence components.") |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
983 (defkeyword :start "Inclusive low index in sequence") |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
984 (defkeyword :end "Exclusive high index in sequence") |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
985 (defkeyword :start1 "Inclusive low index in first of two sequences.") |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
986 (defkeyword :start2 "Inclusive low index in second of two sequences.") |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
987 (defkeyword :end1 "Exclusive high index in first of two sequences.") |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
988 (defkeyword :end2 "Exclusive high index in second of two sequences.") |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
989 (defkeyword :count "Number of elements to affect.") |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
990 (defkeyword :from-end "T when counting backwards.") |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
991 (defkeyword :initial-value "For the syntax of #'reduce") |
188 | 992 |
993 (defun some (pred seq &rest moreseqs) | |
994 "Test PREDICATE on each element of SEQUENCE; is it ever non-nil? | |
995 Extra args are additional sequences; PREDICATE gets one arg from each | |
996 sequence and we advance down all the sequences together in lock-step. | |
997 A sequence means either a list or a vector." | |
998 (let ((args (reassemble-argslists (list* seq moreseqs)))) | |
999 (do* ((ready nil) ;flag: return when t | |
1000 (result nil) ;resulting value | |
1001 (applyval nil) ;result of applying pred once | |
1002 (remaining args | |
1003 (cdr remaining)) ;remaining argument sets | |
1004 (current (car remaining) ;current argument set | |
1005 (car remaining))) | |
1006 ((or ready (endp remaining)) result) | |
1007 (setq applyval (apply pred current)) | |
1008 (when applyval | |
1009 (setq ready t) | |
1010 (setq result applyval))))) | |
1011 | |
1012 (defun every (pred seq &rest moreseqs) | |
1013 "Test PREDICATE on each element of SEQUENCE; is it always non-nil? | |
1014 Extra args are additional sequences; PREDICATE gets one arg from each | |
1015 sequence and we advance down all the sequences together in lock-step. | |
1016 A sequence means either a list or a vector." | |
1017 (let ((args (reassemble-argslists (list* seq moreseqs)))) | |
1018 (do* ((ready nil) ;flag: return when t | |
1019 (result t) ;resulting value | |
1020 (applyval nil) ;result of applying pred once | |
1021 (remaining args | |
1022 (cdr remaining)) ;remaining argument sets | |
1023 (current (car remaining) ;current argument set | |
1024 (car remaining))) | |
1025 ((or ready (endp remaining)) result) | |
1026 (setq applyval (apply pred current)) | |
1027 (unless applyval | |
1028 (setq ready t) | |
1029 (setq result nil))))) | |
1030 | |
1031 (defun notany (pred seq &rest moreseqs) | |
1032 "Test PREDICATE on each element of SEQUENCE; is it always nil? | |
1033 Extra args are additional sequences; PREDICATE gets one arg from each | |
1034 sequence and we advance down all the sequences together in lock-step. | |
1035 A sequence means either a list or a vector." | |
1036 (let ((args (reassemble-argslists (list* seq moreseqs)))) | |
1037 (do* ((ready nil) ;flag: return when t | |
1038 (result t) ;resulting value | |
1039 (applyval nil) ;result of applying pred once | |
1040 (remaining args | |
1041 (cdr remaining)) ;remaining argument sets | |
1042 (current (car remaining) ;current argument set | |
1043 (car remaining))) | |
1044 ((or ready (endp remaining)) result) | |
1045 (setq applyval (apply pred current)) | |
1046 (when applyval | |
1047 (setq ready t) | |
1048 (setq result nil))))) | |
1049 | |
1050 (defun notevery (pred seq &rest moreseqs) | |
1051 "Test PREDICATE on each element of SEQUENCE; is it sometimes nil? | |
1052 Extra args are additional sequences; PREDICATE gets one arg from each | |
1053 sequence and we advance down all the sequences together in lock-step. | |
1054 A sequence means either a list or a vector." | |
1055 (let ((args (reassemble-argslists (list* seq moreseqs)))) | |
1056 (do* ((ready nil) ;flag: return when t | |
1057 (result nil) ;resulting value | |
1058 (applyval nil) ;result of applying pred once | |
1059 (remaining args | |
1060 (cdr remaining)) ;remaining argument sets | |
1061 (current (car remaining) ;current argument set | |
1062 (car remaining))) | |
1063 ((or ready (endp remaining)) result) | |
1064 (setq applyval (apply pred current)) | |
1065 (unless applyval | |
1066 (setq ready t) | |
1067 (setq result t))))) | |
1068 | |
1069 ;;; More sequence functions that don't need keyword arguments | |
1070 | |
1071 (defun concatenate (type &rest sequences) | |
1072 "(concatenate TYPE &rest SEQUENCES) => a sequence | |
1073 The sequence returned is of type TYPE (must be 'list, 'string, or 'vector) and | |
1074 contains the concatenation of the elements of all the arguments, in the order | |
1075 given." | |
1076 (let ((sequences (append sequences '(())))) | |
1077 (case type | |
1078 (list | |
1079 (apply (function append) sequences)) | |
1080 (string | |
1081 (apply (function concat) sequences)) | |
1082 (vector | |
1083 (apply (function vector) (apply (function append) sequences))) | |
1084 (t | |
1085 (error "type for concatenate `%s' not 'list, 'string or 'vector" | |
1086 (prin1-to-string type)))))) | |
1087 | |
1088 (defun map (type function &rest sequences) | |
1089 "(map TYPE FUNCTION &rest SEQUENCES) => a sequence | |
1090 The FUNCTION is called on each set of elements from the SEQUENCES \(stopping | |
1091 when the shortest sequence is terminated\) and the results are possibly | |
1092 returned in a sequence of type TYPE \(one of 'list, 'vector, 'string, or nil\) | |
1093 giving NIL for TYPE gets rid of the values." | |
1094 (if (not (memq type (list 'list 'string 'vector nil))) | |
1095 (error "type for map `%s' not 'list, 'string, 'vector or nil" | |
1096 (prin1-to-string type))) | |
1097 (let ((argslists (reassemble-argslists sequences)) | |
1098 results) | |
1099 (if (null type) | |
1100 (while argslists ;don't bother accumulating | |
1101 (apply function (car argslists)) | |
1102 (setq argslists (cdr argslists))) | |
1103 (setq results (mapcar (function (lambda (args) (apply function args))) | |
1104 argslists)) | |
1105 (case type | |
1106 (list | |
1107 results) | |
1108 (string | |
1109 (funcall (function concat) results)) | |
1110 (vector | |
1111 (apply (function vector) results)))))) | |
1112 | |
1113 ;;; an inverse of elt is needed for setf purposes | |
1114 | |
1115 (defun setelt (seq n newval) | |
1116 "In SEQUENCE, set the Nth element to NEWVAL. Returns NEWVAL. | |
1117 A sequence means either a list or a vector." | |
1118 (let ((l (length seq))) | |
1119 (if (or (< n 0) (>= n l)) | |
1120 (error "N(%d) should be between 0 and %d" n l) | |
1121 ;; only two cases need be considered valid, as strings are arrays | |
1122 (cond ((listp seq) | |
1123 (setnth n seq newval)) | |
1124 ((arrayp seq) | |
1125 (aset seq n newval)) | |
1126 (t | |
1127 (error "SEQ should be a sequence, not `%s'" | |
1128 (prin1-to-string seq))))))) | |
1129 | |
1130 ;;; Testing with keyword arguments. | |
1131 ;;; | |
1132 ;;; Many of the sequence functions use keywords to denote some stylized | |
1133 ;;; form of selecting entries in a sequence. The involved arguments | |
1134 ;;; are collected with a &rest marker (as Emacs Lisp doesn't have a &key | |
1135 ;;; marker), then they are passed to build-klist, who | |
1136 ;;; constructs an association list. That association list is used to | |
1137 ;;; test for satisfaction and matching. | |
1138 | |
1139 ;;; DON'T USE MEMBER, NOR ANY FUNCTION THAT COULD TAKE KEYWORDS HERE!!! | |
1140 | |
1141 (defun build-klist (argslist acceptable &optional allow-other-keys) | |
1142 "Decode a keyword argument list ARGSLIST for keywords in ACCEPTABLE. | |
1143 ARGSLIST is a list, presumably the &rest argument of a call, whose | |
1144 even numbered elements must be keywords. | |
1145 ACCEPTABLE is a list of keywords, the only ones that are truly acceptable. | |
1146 The result is an alist containing the arguments named by the keywords | |
1147 in ACCEPTABLE, or an error is signalled, if something failed. | |
1148 If the third argument (an optional) is non-nil, other keys are acceptable." | |
1149 ;; check legality of the arguments, then destructure them | |
1150 (unless (and (listp argslist) | |
1151 (evenp (length argslist))) | |
1152 (error "build-klist: odd number of keyword-args")) | |
1153 (unless (and (listp acceptable) | |
1154 (every 'keywordp acceptable)) | |
1155 (error "build-klist: second arg should be a list of keywords")) | |
1156 (multiple-value-bind | |
1157 (keywords forms) | |
1158 (unzip-list argslist) | |
1159 (unless (every 'keywordp keywords) | |
1160 (error "build-klist: expected keywords, found `%s'" | |
1161 (prin1-to-string keywords))) | |
1162 (unless (or allow-other-keys | |
1163 (every (function (lambda (keyword) | |
1164 (memq keyword acceptable))) | |
1165 keywords)) | |
1166 (error "bad keyword[s]: %s not in %s" | |
1167 (prin1-to-string (mapcan (function (lambda (keyword) | |
1168 (if (memq keyword acceptable) | |
1169 nil | |
1170 (list keyword)))) | |
1171 keywords)) | |
1172 (prin1-to-string acceptable))) | |
1173 (do* ;;pick up the pieces | |
1174 ((auxlist ;auxiliary a-list, may | |
1175 (pairlis keywords forms)) ;contain repetitions and junk | |
1176 (ptr acceptable (cdr ptr)) ;pointer in acceptable | |
1177 (this (car ptr) (car ptr)) ;current acceptable keyword | |
1178 (auxval nil) ;used to move values around | |
1179 (alist '())) ;used to build the result | |
1180 ((endp ptr) alist) | |
1181 ;; if THIS appears in auxlist, use its value | |
1182 (when (setq auxval (assq this auxlist)) | |
1183 (setq alist (cons auxval alist)))))) | |
1184 | |
1185 | |
1186 (defun extract-from-klist (klist key &optional default) | |
1187 "(extract-from-klist KLIST KEY [DEFAULT]) => value of KEY or DEFAULT | |
1188 Extract value associated with KEY in KLIST (return DEFAULT if nil)." | |
1189 (let ((retrieved (cdr (assq key klist)))) | |
1190 (or retrieved default))) | |
1191 | |
1192 (defun keyword-argument-supplied-p (klist key) | |
1193 "(keyword-argument-supplied-p KLIST KEY) => nil or something | |
1194 NIL if KEY (a keyword) does not appear in the KLIST." | |
1195 (assq key klist)) | |
1196 | |
1197 (defun add-to-klist (key item klist) | |
1198 "(ADD-TO-KLIST KEY ITEM KLIST) => new KLIST | |
1199 Add association (KEY . ITEM) to KLIST." | |
1200 (setq klist (acons key item klist))) | |
1201 | |
1202 (defun elt-satisfies-test-p (item elt klist) | |
1203 "(elt-satisfies-test-p ITEM ELT KLIST) => t or nil | |
1204 KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL. | |
1205 True if the given ITEM and ELT satisfy the test." | |
1206 (let ((test (extract-from-klist klist :test)) | |
1207 (test-not (extract-from-klist klist :test-not)) | |
1208 (keyfn (extract-from-klist klist :key 'identity))) | |
1209 (cond (test | |
1210 (funcall test item (funcall keyfn elt))) | |
1211 (test-not | |
1212 (not (funcall test-not item (funcall keyfn elt)))) | |
1213 (t ;should never happen | |
1214 (error "neither :test nor :test-not in `%s'" | |
1215 (prin1-to-string klist)))))) | |
1216 | |
1217 (defun elt-satisfies-if-p (item klist) | |
1218 "(elt-satisfies-if-p ITEM KLIST) => t or nil | |
1219 True if an -if style function was called and ITEM satisfies the | |
1220 predicate under :predicate in KLIST." | |
1221 (let ((predicate (extract-from-klist klist :predicate)) | |
1222 (keyfn (extract-from-klist klist :key 'identity))) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1223 (funcall predicate (funcall keyfn item)))) |
188 | 1224 |
1225 (defun elt-satisfies-if-not-p (item klist) | |
1226 "(elt-satisfies-if-not-p ITEM KLIST) => t or nil | |
1227 KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL. | |
1228 True if an -if-not style function was called and ITEM does not satisfy | |
1229 the predicate under :predicate in KLIST." | |
1230 (let ((predicate (extract-from-klist klist :predicate)) | |
1231 (keyfn (extract-from-klist klist :key 'identity))) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1232 (not (funcall predicate (funcall keyfn item))))) |
188 | 1233 |
1234 (defun elts-match-under-klist-p (e1 e2 klist) | |
1235 "(elts-match-under-klist-p E1 E2 KLIST) => t or nil | |
1236 KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL. | |
1237 True if elements E1 and E2 match under the tests encoded in KLIST." | |
1238 (let ((test (extract-from-klist klist :test)) | |
1239 (test-not (extract-from-klist klist :test-not)) | |
1240 (keyfn (extract-from-klist klist :key 'identity))) | |
1241 (if (and test test-not) | |
1242 (error "both :test and :test-not in `%s'" | |
1243 (prin1-to-string klist))) | |
1244 (cond (test | |
1245 (funcall test (funcall keyfn e1) (funcall keyfn e2))) | |
1246 (test-not | |
1247 (not (funcall test-not (funcall keyfn e1) (funcall keyfn e2)))) | |
1248 (t ;should never happen | |
1249 (error "neither :test nor :test-not in `%s'" | |
1250 (prin1-to-string klist)))))) | |
1251 | |
1252 ;;; This macro simplifies using keyword args. It is less clumsy than using | |
1253 ;;; the primitives build-klist, etc... For instance, member could be written | |
1254 ;;; this way: | |
1255 | |
1256 ;;; (defun member (item list &rest kargs) | |
1257 ;;; (with-keyword-args kargs (test test-not (key 'identity)) | |
1258 ;;; ...)) | |
1259 | |
1260 ;;; Suggested by Robert Potter (potter@cs.rochester.edu, 15 Nov 1989) | |
1261 | |
1262 (defmacro with-keyword-args (keyargslist vardefs &rest body) | |
1263 "(WITH-KEYWORD-ARGS KEYARGSLIST VARDEFS . BODY) | |
1264 KEYARGSLIST can be either a symbol or a list of one or two symbols. | |
1265 In the second case, the second symbol is either T or NIL, indicating whether | |
1266 keywords other than the mentioned ones are tolerable. | |
1267 | |
1268 VARDEFS is a list. Each entry is either a VAR (symbol) or matches | |
1269 \(VAR [DEFAULT [KEYWORD]]). Just giving VAR is the same as giving | |
1270 \(VAR nil :VAR). | |
1271 | |
1272 The BODY is executed in an environment where each VAR (a symbol) is bound to | |
1273 the value present in the KEYARGSLIST provided, or to the DEFAULT. The value | |
1274 is searched by using the keyword form of VAR (i.e., :VAR) or the optional | |
1275 keyword if provided. | |
1276 | |
1277 Notice that this macro doesn't distinguish between a default value given | |
1278 explicitly by the user and one provided by default. See also the more | |
1279 primitive functions build-klist, add-to-klist, extract-from-klist, | |
1280 keyword-argument-supplied-p, elt-satisfies-test-p, elt-satisfies-if-p, | |
1281 elt-satisfies-if-not-p, elts-match-under-klist-p. They provide more complete, | |
1282 if clumsier, control over this feature." | |
1283 (let (allow-other-keys) | |
1284 (if (listp keyargslist) | |
1285 (if (> (length keyargslist) 2) | |
1286 (error | |
1287 "`%s' should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)" | |
1288 (prin1-to-string keyargslist)) | |
1289 (setq allow-other-keys (cadr keyargslist) | |
1290 keyargslist (car keyargslist)) | |
1291 (if (not (and | |
1292 (symbolp keyargslist) | |
1293 (memq allow-other-keys '(t nil)))) | |
1294 (error | |
1295 "first subform should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)" | |
1296 ))) | |
1297 (if (symbolp keyargslist) | |
1298 (setq allow-other-keys nil) | |
1299 (error | |
1300 "first subform should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)"))) | |
1301 (let (vars defaults keywords forms | |
1302 (klistname (gensym "KLIST_"))) | |
1303 (mapcar (function (lambda (entry) | |
1304 (if (symbolp entry) ;defaulty case | |
1305 (setq entry (list entry nil (keyword-of entry)))) | |
1306 (let* ((l (length entry)) | |
1307 (v (car entry)) | |
1308 (d (cadr entry)) | |
1309 (k (caddr entry))) | |
1310 (if (or (< l 1) (> l 3)) | |
1311 (error | |
1312 "`%s' must match (VAR [DEFAULT [KEYWORD]])" | |
1313 (prin1-to-string entry))) | |
1314 (if (or (null v) (not (symbolp v))) | |
1315 (error | |
1316 "bad variable `%s': must be non-null symbol" | |
1317 (prin1-to-string v))) | |
1318 (setq vars (cons v vars)) | |
1319 (setq defaults (cons d defaults)) | |
1320 (if (< l 3) | |
1321 (setq k (keyword-of v))) | |
1322 (if (and (= l 3) | |
1323 (or (null k) | |
1324 (not (keywordp k)))) | |
1325 (error | |
1326 "bad keyword `%s'" (prin1-to-string k))) | |
1327 (setq keywords (cons k keywords)) | |
1328 (setq forms (cons (list v (list 'extract-from-klist | |
1329 klistname | |
1330 k | |
1331 d)) | |
1332 forms))))) | |
1333 vardefs) | |
1334 (append | |
1335 (list 'let* (nconc (list (list klistname | |
1336 (list 'build-klist keyargslist | |
1337 (list 'quote keywords) | |
1338 allow-other-keys))) | |
1339 (nreverse forms))) | |
1340 body)))) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1341 (put 'with-keyword-args 'lisp-indent-hook 1) |
188 | 1342 |
1343 | |
1344 ;;; REDUCE | |
1345 ;;; It is here mostly as an example of how to use KLISTs. | |
1346 ;;; | |
1347 ;;; First of all, you need to declare the keywords (done elsewhere in this | |
1348 ;;; file): | |
1349 ;;; (defkeyword :from-end "syntax of sequence functions") | |
1350 ;;; (defkeyword :start "syntax of sequence functions") | |
1351 ;;; etc... | |
1352 ;;; | |
1353 ;;; Then, you capture all the possible keyword arguments with a &rest | |
1354 ;;; argument. You can pass that list downward again, of course, but | |
1355 ;;; internally you need to parse it into a KLIST (an alist, really). One uses | |
1356 ;;; (build-klist REST-ARGS ACCEPTABLE-KEYWORDS [ALLOW-OTHER]). You can then | |
1357 ;;; test for presence by using (keyword-argument-supplied-p KLIST KEY) and | |
1358 ;;; extract a value with (extract-from-klist KLIST KEY [DEFAULT]). | |
1359 | |
1360 (defun reduce (function sequence &rest kargs) | |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
3395
diff
changeset
|
1361 "Apply FUNCTION (a function of two arguments) to successive pairs of elements |
188 | 1362 from SEQUENCE. Some keyword arguments are valid after FUNCTION and SEQUENCE: |
1363 :from-end If non-nil, process the values backwards | |
1364 :initial-value If given, prefix it to the SEQUENCE. Suffix, if :from-end | |
1365 :start Restrict reduction to the subsequence from this index | |
1366 :end Restrict reduction to the subsequence BEFORE this index. | |
1367 If the sequence is empty and no :initial-value is given, the FUNCTION is | |
1368 called on zero (not two) arguments. Otherwise, if there is exactly one | |
1369 element in the combination of SEQUENCE and the initial value, that element is | |
1370 returned." | |
1371 (let* ((klist (build-klist kargs '(:from-end :start :end :initial-value))) | |
1372 (length (length sequence)) | |
1373 (from-end (extract-from-klist klist :from-end)) | |
1374 (initial-value-given (keyword-argument-supplied-p | |
1375 klist :initial-value)) | |
1376 (start (extract-from-klist kargs :start 0)) | |
1377 (end (extract-from-klist kargs :end length))) | |
1378 (setq sequence (cl$subseq-as-list sequence start end)) | |
1379 (if from-end | |
1380 (setq sequence (reverse sequence))) | |
1381 (if initial-value-given | |
1382 (setq sequence (cons (extract-from-klist klist :initial-value) | |
1383 sequence))) | |
1384 (if (null sequence) | |
1385 (funcall function) ;only use of 0 arguments | |
1386 (let* ((result (car sequence)) | |
1387 (sequence (cdr sequence))) | |
1388 (while sequence | |
1389 (setq result (if from-end | |
1390 (funcall function (car sequence) result) | |
1391 (funcall function result (car sequence))) | |
1392 sequence (cdr sequence))) | |
1393 result)))) | |
1394 | |
1395 (defun cl$subseq-as-list (sequence start end) | |
1396 "(cl$subseq-as-list SEQUENCE START END) => a list" | |
1397 (let ((list (append sequence nil)) | |
1398 (length (length sequence)) | |
1399 result) | |
1400 (if (< start 0) | |
1401 (error "start should be >= 0, not %d" start)) | |
1402 (if (> end length) | |
1403 (error "end should be <= %d, not %d" length end)) | |
1404 (if (and (zerop start) (= end length)) | |
1405 list | |
1406 (let ((i start) | |
1407 (vector (apply 'vector list))) | |
1408 (while (/= i end) | |
1409 (setq result (cons (elt vector i) result)) | |
1410 (setq i (+ i 1))) | |
1411 (nreverse result))))) | |
1412 | |
1413 ;;;; end of cl-sequences.el | |
1414 | |
1415 ;;;; Some functions with keyword arguments | |
1416 ;;;; | |
1417 ;;;; Both list and sequence functions are considered here together. This | |
1418 ;;;; doesn't fit any more with the original split of functions in files. | |
1419 | |
3168
762660cd6d9d
(cl-member): Renamed from member.
Richard M. Stallman <rms@gnu.org>
parents:
2967
diff
changeset
|
1420 (defun cl-member (item list &rest kargs) |
188 | 1421 "Look for ITEM in LIST; return first tail of LIST the car of whose first |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1422 cons cell tests the same as ITEM. Admits arguments :key, :test, and |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1423 :test-not." |
188 | 1424 (if (null kargs) ;treat this fast for efficiency |
1425 (memq item list) | |
1426 (let* ((klist (build-klist kargs '(:test :test-not :key))) | |
1427 (test (extract-from-klist klist :test)) | |
1428 (testnot (extract-from-klist klist :test-not)) | |
1429 (key (extract-from-klist klist :key 'identity))) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1430 ;; another workaround allegedly for speed, BLAH |
188 | 1431 (if (and (or (eq test 'eq) (eq test 'eql) |
1432 (eq test (symbol-function 'eq)) | |
1433 (eq test (symbol-function 'eql))) | |
1434 (null testnot) | |
1435 (or (eq key 'identity) ;either by default or so given | |
1436 (eq key (function identity)) ;could this happen? | |
1437 (eq key (symbol-function 'identity)) ;sheer paranoia | |
1438 )) | |
1439 (memq item list) | |
1440 (if (and test testnot) | |
1441 (error ":test and :test-not both specified for member")) | |
1442 (if (not (or test testnot)) | |
1443 (setq test 'eql)) | |
1444 ;; final hack: remove the indirection through the function names | |
1445 (if testnot | |
1446 (if (symbolp testnot) | |
1447 (setq testnot (symbol-function testnot))) | |
1448 (if (symbolp test) | |
1449 (setq test (symbol-function test)))) | |
1450 (if (symbolp key) | |
1451 (setq key (symbol-function key))) | |
1452 ;; ok, go for it | |
1453 (let ((ptr list) | |
1454 (done nil) | |
1455 (result '())) | |
1456 (if testnot | |
1457 (while (not (or done (endp ptr))) | |
1458 (cond ((not (funcall testnot item (funcall key (car ptr)))) | |
1459 (setq done t) | |
1460 (setq result ptr))) | |
1461 (setq ptr (cdr ptr))) | |
1462 (while (not (or done (endp ptr))) | |
1463 (cond ((funcall test item (funcall key (car ptr))) | |
1464 (setq done t) | |
1465 (setq result ptr))) | |
1466 (setq ptr (cdr ptr)))) | |
1467 result))))) | |
1468 | |
1469 ;;;; MULTIPLE VALUES | |
1470 ;;;; This package approximates the behavior of the multiple-values | |
1471 ;;;; forms of Common Lisp. | |
1472 ;;;; | |
1473 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 | |
1474 ;;;; (quiroz@cs.rochester.edu) | |
1475 | |
1476 ;;; Lisp indentation information | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1477 (put 'multiple-value-bind 'lisp-indent-hook 2) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1478 (put 'multiple-value-setq 'lisp-indent-hook 2) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1479 (put 'multiple-value-list 'lisp-indent-hook nil) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1480 (put 'multiple-value-call 'lisp-indent-hook 1) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1481 (put 'multiple-value-prog1 'lisp-indent-hook 1) |
188 | 1482 |
1483 ;;; Global state of the package is kept here | |
1484 (defvar *mvalues-values* nil | |
1485 "Most recently returned multiple-values") | |
1486 (defvar *mvalues-count* nil | |
1487 "Count of multiple-values returned, or nil if the mechanism was not used") | |
1488 | |
1489 ;;; values is the standard multiple-value-return form. Must be the | |
1490 ;;; last thing evaluated inside a function. If the caller is not | |
1491 ;;; expecting multiple values, only the first one is passed. (values) | |
1492 ;;; is the same as no-values returned (unaware callers see nil). The | |
1493 ;;; alternative (values-list <list>) is just a convenient shorthand | |
1494 ;;; and complements multiple-value-list. | |
1495 | |
1496 (defun values (&rest val-forms) | |
1497 "Produce multiple values (zero or more). Each arg is one value. | |
1498 See also `multiple-value-bind', which is one way to examine the | |
1499 multiple values produced by a form. If the containing form or caller | |
1500 does not check specially to see multiple values, it will see only | |
1501 the first value." | |
1502 (setq *mvalues-values* val-forms) | |
1503 (setq *mvalues-count* (length *mvalues-values*)) | |
1504 (car *mvalues-values*)) | |
1505 | |
1506 (defun values-list (&optional val-forms) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1507 "Produce multiple values (zero or more). Each element of LIST is one value. |
188 | 1508 This is equivalent to (apply 'values LIST)." |
1509 (cond ((nlistp val-forms) | |
1510 (error "Argument to values-list must be a list, not `%s'" | |
1511 (prin1-to-string val-forms)))) | |
1512 (setq *mvalues-values* val-forms) | |
1513 (setq *mvalues-count* (length *mvalues-values*)) | |
1514 (car *mvalues-values*)) | |
1515 | |
1516 ;;; Callers that want to see the multiple values use these macros. | |
1517 | |
1518 (defmacro multiple-value-list (form) | |
1519 "Execute FORM and return a list of all the (multiple) values FORM produces. | |
1520 See `values' and `multiple-value-bind'." | |
1521 (list 'progn | |
1522 (list 'setq '*mvalues-count* nil) | |
1523 (list 'let (list (list 'it '(gensym))) | |
1524 (list 'set 'it form) | |
1525 (list 'if '*mvalues-count* | |
1526 (list 'copy-sequence '*mvalues-values*) | |
1527 (list 'progn | |
1528 (list 'setq '*mvalues-count* 1) | |
1529 (list 'setq '*mvalues-values* | |
1530 (list 'list (list 'symbol-value 'it))) | |
1531 (list 'copy-sequence '*mvalues-values*)))))) | |
1532 | |
1533 (defmacro multiple-value-call (function &rest args) | |
1534 "Call FUNCTION on all the values produced by the remaining arguments. | |
1535 (multiple-value-call '+ (values 1 2) (values 3 4)) is 10." | |
1536 (let* ((result (gentemp)) | |
1537 (arg (gentemp))) | |
1538 (list 'apply (list 'function (eval function)) | |
1539 (list 'let* (list (list result '())) | |
1540 (list 'dolist (list arg (list 'quote args) result) | |
1541 (list 'setq result | |
1542 (list 'append | |
1543 result | |
1544 (list 'multiple-value-list | |
1545 (list 'eval arg))))))))) | |
1546 | |
1547 (defmacro multiple-value-bind (vars form &rest body) | |
1548 "Bind VARS to the (multiple) values produced by FORM, then do BODY. | |
1549 VARS is a list of variables; each is bound to one of FORM's values. | |
1550 If FORM doesn't make enough values, the extra variables are bound to nil. | |
1551 (Ordinary forms produce only one value; to produce more, use `values'.) | |
1552 Extra values are ignored. | |
1553 BODY (zero or more forms) is executed with the variables bound, | |
1554 then the bindings are unwound." | |
1555 (let* ((vals (gentemp)) ;name for intermediate values | |
1556 (clauses (mv-bind-clausify ;convert into clauses usable | |
1557 vars vals))) ; in a let form | |
1558 (list* 'let* | |
1559 (cons (list vals (list 'multiple-value-list form)) | |
1560 clauses) | |
1561 body))) | |
1562 | |
1563 (defmacro multiple-value-setq (vars form) | |
1564 "Set VARS to the (multiple) values produced by FORM. | |
1565 VARS is a list of variables; each is set to one of FORM's values. | |
1566 If FORM doesn't make enough values, the extra variables are set to nil. | |
1567 (Ordinary forms produce only one value; to produce more, use `values'.) | |
1568 Extra values are ignored." | |
1569 (let* ((vals (gentemp)) ;name for intermediate values | |
1570 (clauses (mv-bind-clausify ;convert into clauses usable | |
1571 vars vals))) ; in a setq (after append). | |
1572 (list 'let* | |
1573 (list (list vals (list 'multiple-value-list form))) | |
1574 (cons 'setq (apply (function append) clauses))))) | |
1575 | |
1576 (defmacro multiple-value-prog1 (form &rest body) | |
1577 "Evaluate FORM, then BODY, then produce the same values FORM produced. | |
1578 Thus, (multiple-value-prog1 (values 1 2) (foobar)) produces values 1 and 2. | |
1579 This is like `prog1' except that `prog1' would produce only one value, | |
1580 which would be the first of FORM's values." | |
1581 (let* ((heldvalues (gentemp))) | |
1582 (cons 'let* | |
1583 (cons (list (list heldvalues (list 'multiple-value-list form))) | |
1584 (append body (list (list 'values-list heldvalues))))))) | |
1585 | |
1586 ;;; utility functions | |
1587 ;;; | |
1588 ;;; mv-bind-clausify makes the pairs needed to have the variables in | |
1589 ;;; the variable list correspond with the values returned by the form. | |
1590 ;;; vals is a fresh symbol that intervenes in all the bindings. | |
1591 | |
1592 (defun mv-bind-clausify (vars vals) | |
1593 "MV-BIND-CLAUSIFY VARS VALS => Auxiliary list | |
1594 Forms a list of pairs `(,(nth i vars) (nth i vals)) for i from 0 to | |
1595 the length of VARS (a list of symbols). VALS is just a fresh symbol." | |
1596 (if (or (nlistp vars) | |
1597 (notevery 'symbolp vars)) | |
1598 (error "expected a list of symbols, not `%s'" | |
1599 (prin1-to-string vars))) | |
1600 (let* ((nvars (length vars)) | |
1601 (clauses '())) | |
1602 (dotimes (n nvars clauses) | |
1603 (setq clauses (cons (list (nth n vars) | |
1604 (list 'nth n vals)) clauses))))) | |
1605 | |
1606 ;;;; end of cl-multiple-values.el | |
1607 | |
1608 ;;;; ARITH | |
1609 ;;;; This file provides integer arithmetic extensions. Although | |
1610 ;;;; Emacs Lisp doesn't really support anything but integers, that | |
1611 ;;;; has still to be made to look more or less standard. | |
1612 ;;;; | |
1613 ;;;; | |
1614 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 | |
1615 ;;;; (quiroz@cs.rochester.edu) | |
1616 | |
1617 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1618 (defsubst plusp (number) |
188 | 1619 "True if NUMBER is strictly greater than zero." |
1620 (> number 0)) | |
1621 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1622 (defsubst minusp (number) |
188 | 1623 "True if NUMBER is strictly less than zero." |
1624 (< number 0)) | |
1625 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1626 (defsubst oddp (number) |
188 | 1627 "True if INTEGER is not divisible by 2." |
1628 (/= (% number 2) 0)) | |
1629 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1630 (defsubst evenp (number) |
188 | 1631 "True if INTEGER is divisible by 2." |
1632 (= (% number 2) 0)) | |
1633 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1634 (defsubst abs (number) |
188 | 1635 "Return the absolute value of NUMBER." |
1636 (if (< number 0) | |
1637 (- number) | |
1638 number)) | |
1639 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1640 (defsubst signum (number) |
188 | 1641 "Return -1, 0 or 1 according to the sign of NUMBER." |
1642 (cond ((< number 0) | |
1643 -1) | |
1644 ((> number 0) | |
1645 1) | |
1646 (t ;exactly zero | |
1647 0))) | |
1648 | |
1649 (defun gcd (&rest integers) | |
1650 "Return the greatest common divisor of all the arguments. | |
1651 The arguments must be integers. With no arguments, value is zero." | |
1652 (let ((howmany (length integers))) | |
1653 (cond ((= howmany 0) | |
1654 0) | |
1655 ((= howmany 1) | |
1656 (abs (car integers))) | |
1657 ((> howmany 2) | |
1658 (apply (function gcd) | |
1659 (cons (gcd (nth 0 integers) (nth 1 integers)) | |
1660 (nthcdr 2 integers)))) | |
1661 (t ;howmany=2 | |
1662 ;; essentially the euclidean algorithm | |
1663 (when (zerop (* (nth 0 integers) (nth 1 integers))) | |
1664 (error "a zero argument is invalid for `gcd'")) | |
1665 (do* ((absa (abs (nth 0 integers))) ; better to operate only | |
1666 (absb (abs (nth 1 integers))) ;on positives. | |
1667 (dd (max absa absb)) ; setup correct order for the | |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
3395
diff
changeset
|
1668 (ds (min absa absb)) ;successive divisions. |
188 | 1669 ;; intermediate results |
1670 (q 0) | |
1671 (r 0) | |
1672 ;; final results | |
1673 (done nil) ; flag: end of iterations | |
1674 (result 0)) ; final value | |
1675 (done result) | |
1676 (setq q (/ dd ds)) | |
1677 (setq r (% dd ds)) | |
1678 (cond ((zerop r) (setq done t) (setq result ds)) | |
1679 (t (setq dd ds) (setq ds r)))))))) | |
1680 | |
1681 (defun lcm (integer &rest more) | |
1682 "Return the least common multiple of all the arguments. | |
1683 The arguments must be integers and there must be at least one of them." | |
1684 (let ((howmany (length more)) | |
1685 (a integer) | |
1686 (b (nth 0 more)) | |
1687 prod ; intermediate product | |
1688 (yetmore (nthcdr 1 more))) | |
1689 (cond ((zerop howmany) | |
1690 (abs a)) | |
1691 ((> howmany 1) ; recursive case | |
1692 (apply (function lcm) | |
1693 (cons (lcm a b) yetmore))) | |
1694 (t ; base case, just 2 args | |
1695 (setq prod (* a b)) | |
1696 (cond | |
1697 ((zerop prod) | |
1698 0) | |
1699 (t | |
1700 (/ (abs prod) (gcd a b)))))))) | |
1701 | |
1702 (defun isqrt (number) | |
1703 "Return the integer square root of NUMBER. | |
1704 NUMBER must not be negative. Result is largest integer less than or | |
1705 equal to the real square root of the argument." | |
1706 ;; The method used here is essentially the Newtonian iteration | |
1707 ;; x[n+1] <- (x[n] + Number/x[n]) / 2 | |
1708 ;; suitably adapted to integer arithmetic. | |
1709 ;; Thanks to Philippe Schnoebelen <phs@lifia.imag.fr> for suggesting the | |
1710 ;; termination condition. | |
1711 (cond ((minusp number) | |
1712 (error "argument to `isqrt' (%d) must not be negative" | |
1713 number)) | |
1714 ((zerop number) | |
1715 0) | |
1716 (t ;so (>= number 0) | |
1717 (do* ((approx 1) ;any positive integer will do | |
1718 (new 0) ;init value irrelevant | |
1719 (done nil)) | |
1720 (done (if (> (* approx approx) number) | |
1721 (- approx 1) | |
1722 approx)) | |
1723 (setq new (/ (+ approx (/ number approx)) 2) | |
1724 done (or (= new approx) (= new (+ approx 1))) | |
1725 approx new))))) | |
1726 | |
2967
6b62c36ce82e
* cl.el (cl-floor, cl-ceiling, cl-truncate, cl-round): Renamed
Jim Blandy <jimb@redhat.com>
parents:
2229
diff
changeset
|
1727 (defun cl-floor (number &optional divisor) |
188 | 1728 "Divide DIVIDEND by DIVISOR, rounding toward minus infinity. |
1729 DIVISOR defaults to 1. The remainder is produced as a second value." | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1730 (cond ((and (null divisor) ; trivial case |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1731 (numberp number)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1732 (values number 0)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1733 (t ; do the division |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1734 (multiple-value-bind |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1735 (q r s) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1736 (safe-idiv number divisor) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1737 (cond ((zerop s) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1738 (values 0 0)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1739 ((plusp s) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1740 (values q r)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1741 (t ;opposite-signs case |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1742 (if (zerop r) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1743 (values (- q) 0) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1744 (let ((q (- (+ q 1)))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1745 (values q (- number (* q divisor))))))))))) |
188 | 1746 |
2967
6b62c36ce82e
* cl.el (cl-floor, cl-ceiling, cl-truncate, cl-round): Renamed
Jim Blandy <jimb@redhat.com>
parents:
2229
diff
changeset
|
1747 (defun cl-ceiling (number &optional divisor) |
188 | 1748 "Divide DIVIDEND by DIVISOR, rounding toward plus infinity. |
1749 DIVISOR defaults to 1. The remainder is produced as a second value." | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1750 (cond ((and (null divisor) ; trivial case |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1751 (numberp number)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1752 (values number 0)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1753 (t ; do the division |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1754 (multiple-value-bind |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1755 (q r s) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1756 (safe-idiv number divisor) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1757 (cond ((zerop s) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1758 (values 0 0)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1759 ((plusp s) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1760 (values (+ q 1) (- r divisor))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1761 (t |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1762 (values (- q) (+ number (* q divisor))))))))) |
188 | 1763 |
2967
6b62c36ce82e
* cl.el (cl-floor, cl-ceiling, cl-truncate, cl-round): Renamed
Jim Blandy <jimb@redhat.com>
parents:
2229
diff
changeset
|
1764 (defun cl-truncate (number &optional divisor) |
188 | 1765 "Divide DIVIDEND by DIVISOR, rounding toward zero. |
1766 DIVISOR defaults to 1. The remainder is produced as a second value." | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1767 (cond ((and (null divisor) ; trivial case |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1768 (numberp number)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1769 (values number 0)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1770 (t ; do the division |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1771 (multiple-value-bind |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1772 (q r s) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1773 (safe-idiv number divisor) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1774 (cond ((zerop s) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1775 (values 0 0)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1776 ((plusp s) ;same as floor |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1777 (values q r)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1778 (t ;same as ceiling |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1779 (values (- q) (+ number (* q divisor))))))))) |
188 | 1780 |
2967
6b62c36ce82e
* cl.el (cl-floor, cl-ceiling, cl-truncate, cl-round): Renamed
Jim Blandy <jimb@redhat.com>
parents:
2229
diff
changeset
|
1781 (defun cl-round (number &optional divisor) |
188 | 1782 "Divide DIVIDEND by DIVISOR, rounding to nearest integer. |
1783 DIVISOR defaults to 1. The remainder is produced as a second value." | |
1784 (cond ((and (null divisor) ; trivial case | |
1785 (numberp number)) | |
1786 (values number 0)) | |
1787 (t ; do the division | |
1788 (multiple-value-bind | |
1789 (q r s) | |
1790 (safe-idiv number divisor) | |
1791 (setq r (abs r)) | |
1792 ;; adjust magnitudes first, and then signs | |
1793 (let ((other-r (- (abs divisor) r))) | |
1794 (cond ((> r other-r) | |
1795 (setq q (+ q 1))) | |
1796 ((and (= r other-r) | |
1797 (oddp q)) | |
1798 ;; round to even is mandatory | |
1799 (setq q (+ q 1)))) | |
1800 (setq q (* s q)) | |
1801 (setq r (- number (* q divisor))) | |
1802 (values q r)))))) | |
1803 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1804 ;;; These two functions access the implementation-dependent representation of |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1805 ;;; the multiple value returns. |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1806 |
3395
a8401c78dadc
(cl-mod): Renamed from mod.
Richard M. Stallman <rms@gnu.org>
parents:
3346
diff
changeset
|
1807 (defun cl-mod (number divisor) |
188 | 1808 "Return remainder of X by Y (rounding quotient toward minus infinity). |
3346 | 1809 That is, the remainder goes with the quotient produced by `cl-floor'. |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1810 Emacs Lisp hint: |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1811 If you know that both arguments are positive, use `%' instead for speed." |
3346 | 1812 (cl-floor number divisor) |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1813 (cadr *mvalues-values*)) |
188 | 1814 |
1815 (defun rem (number divisor) | |
1816 "Return remainder of X by Y (rounding quotient toward zero). | |
3346 | 1817 That is, the remainder goes with the quotient produced by `cl-truncate'. |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1818 Emacs Lisp hint: |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1819 If you know that both arguments are positive, use `%' instead for speed." |
3346 | 1820 (cl-truncate number divisor) |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1821 (cadr *mvalues-values*)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1822 |
188 | 1823 ;;; internal utilities |
1824 ;;; | |
1825 ;;; safe-idiv performs an integer division with positive numbers only. | |
1826 ;;; It is known that some machines/compilers implement weird remainder | |
1827 ;;; computations when working with negatives, so the idea here is to | |
1828 ;;; make sure we know what is coming back to the caller in all cases. | |
1829 | |
1830 ;;; Signum computation fixed by mad@math.keio.JUNET (MAEDA Atusi) | |
1831 | |
1832 (defun safe-idiv (a b) | |
1833 "SAFE-IDIV A B => Q R S | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1834 Q=|A|/|B|, S is the sign of A/B, R is the rest A - S*Q*B." |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1835 ;; (unless (and (numberp a) (numberp b)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1836 ;; (error "arguments to `safe-idiv' must be numbers")) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1837 ;; (when (zerop b) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1838 ;; (error "cannot divide %d by zero" a)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1839 (let* ((q (/ (abs a) (abs b))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1840 (s (* (signum a) (signum b))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1841 (r (- a (* s q b)))) |
188 | 1842 (values q r s))) |
1843 | |
1844 ;;;; end of cl-arith.el | |
1845 | |
1846 ;;;; SETF | |
1847 ;;;; This file provides the setf macro and friends. The purpose has | |
1848 ;;;; been modest, only the simplest defsetf forms are accepted. | |
1849 ;;;; Use it and enjoy. | |
1850 ;;;; | |
1851 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 | |
1852 ;;;; (quiroz@cs.rochester.edu) | |
1853 | |
1854 | |
1855 (defkeyword :setf-update-fn | |
1856 "Property, its value is the function setf must invoke to update a | |
1857 generalized variable whose access form is a function call of the | |
1858 symbol that has this property.") | |
1859 | |
1860 (defkeyword :setf-update-doc | |
1861 "Property of symbols that have a `defsetf' update function on them, | |
1862 installed by the `defsetf' from its optional third argument.") | |
1863 | |
1864 (defmacro setf (&rest pairs) | |
1865 "Generalized `setq' that can set things other than variable values. | |
1866 A use of `setf' looks like (setf {PLACE VALUE}...). | |
1867 The behavior of (setf PLACE VALUE) is to access the generalized variable | |
1868 at PLACE and store VALUE there. It returns VALUE. If there is more | |
1869 than one PLACE and VALUE, each PLACE is set from its VALUE before | |
1870 the next PLACE is evaluated." | |
1871 (let ((nforms (length pairs))) | |
1872 ;; check the number of subforms | |
1873 (cond ((/= (% nforms 2) 0) | |
1874 (error "odd number of arguments to `setf'")) | |
1875 ((= nforms 0) | |
1876 nil) | |
1877 ((> nforms 2) | |
1878 ;; this is the recursive case | |
1879 (cons 'progn | |
1880 (do* ;collect the place-value pairs | |
1881 ((args pairs (cddr args)) | |
1882 (place (car args) (car args)) | |
1883 (value (cadr args) (cadr args)) | |
1884 (result '())) | |
1885 ((endp args) (nreverse result)) | |
1886 (setq result | |
1887 (cons (list 'setf place value) | |
1888 result))))) | |
1889 (t ;i.e., nforms=2 | |
1890 ;; this is the base case (SETF PLACE VALUE) | |
1891 (let* ((place (car pairs)) | |
1892 (value (cadr pairs)) | |
1893 (head nil) | |
1894 (updatefn nil)) | |
1895 ;; dispatch on the type of the PLACE | |
1896 (cond ((symbolp place) | |
1897 (list 'setq place value)) | |
1898 ((and (listp place) | |
1899 (setq head (car place)) | |
1900 (symbolp head) | |
1901 (setq updatefn (get head :setf-update-fn))) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1902 ;; dispatch on the type of update function |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1903 (cond ((and (consp updatefn) (eq (car updatefn) 'lambda)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1904 (cons 'funcall |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1905 (cons (list 'function updatefn) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1906 (append (cdr place) (list value))))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1907 ((and (symbolp updatefn) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1908 (fboundp updatefn) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1909 (let ((defn (symbol-function updatefn))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1910 (or (subrp defn) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1911 (and (consp defn) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1912 (or (eq (car defn) 'lambda) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1913 (eq (car defn) 'macro)))))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1914 (cons updatefn (append (cdr place) (list value)))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1915 (t |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1916 (multiple-value-bind |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1917 (bindings newsyms) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1918 (pair-with-newsyms |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1919 (append (cdr place) (list value))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1920 ;; this let gets new symbols to ensure adequate |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1921 ;; order of evaluation of the subforms. |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1922 (list 'let |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1923 bindings |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
1924 (cons updatefn newsyms)))))) |
188 | 1925 (t |
1926 (error "no `setf' update-function for `%s'" | |
1927 (prin1-to-string place))))))))) | |
1928 | |
1929 (defmacro defsetf (accessfn updatefn &optional docstring) | |
1930 "Define how `setf' works on a certain kind of generalized variable. | |
1931 A use of `defsetf' looks like (defsetf ACCESSFN UPDATEFN [DOCSTRING]). | |
1932 ACCESSFN is a symbol. UPDATEFN is a function or macro which takes | |
1933 one more argument than ACCESSFN does. DEFSETF defines the translation | |
1934 of (SETF (ACCESFN . ARGS) NEWVAL) to be a form like (UPDATEFN ARGS... NEWVAL). | |
1935 The function UPDATEFN must return its last arg, after performing the | |
1936 updating called for." | |
1937 ;; reject ill-formed requests. too bad one can't test for functionp | |
1938 ;; or macrop. | |
1939 (when (not (symbolp accessfn)) | |
1940 (error "first argument of `defsetf' must be a symbol, not `%s'" | |
1941 (prin1-to-string accessfn))) | |
1942 ;; update properties | |
1943 (list 'progn | |
2000
cf8515fda17b
(defsetf): Use eval-and-compile for self-update-fn.
Richard M. Stallman <rms@gnu.org>
parents:
1861
diff
changeset
|
1944 (list 'eval-and-compile |
cf8515fda17b
(defsetf): Use eval-and-compile for self-update-fn.
Richard M. Stallman <rms@gnu.org>
parents:
1861
diff
changeset
|
1945 (list 'put (list 'quote accessfn) |
cf8515fda17b
(defsetf): Use eval-and-compile for self-update-fn.
Richard M. Stallman <rms@gnu.org>
parents:
1861
diff
changeset
|
1946 :setf-update-fn (list 'function updatefn))) |
188 | 1947 (list 'put (list 'quote accessfn) :setf-update-doc docstring) |
1948 ;; any better thing to return? | |
1949 (list 'quote accessfn))) | |
1950 | |
1951 ;;; This section provides the "default" setfs for Common-Emacs-Lisp | |
1952 ;;; The user will not normally add anything to this, although | |
1953 ;;; defstruct will introduce new ones as a matter of fact. | |
1954 ;;; | |
1955 ;;; Apply is a special case. The Common Lisp | |
1956 ;;; standard makes the case of apply be useful when the user writes | |
1957 ;;; something like (apply #'name ...), Emacs Lisp doesn't have the # | |
1958 ;;; stuff, but it has (function ...). Notice that V18 includes a new | |
1959 ;;; apply: this file is compatible with V18 and pre-V18 Emacses. | |
1960 | |
1961 ;;; INCOMPATIBILITY: the SETF macro evaluates its arguments in the | |
1962 ;;; (correct) left to right sequence *before* checking for apply | |
1963 ;;; methods (which should really be an special case inside setf). Due | |
1964 ;;; to this, the lambda expression defsetf'd to apply will succeed in | |
1965 ;;; applying the right function even if the name was not quoted, but | |
1966 ;;; computed! That extension is not Common Lisp (nor is particularly | |
1967 ;;; useful, I think). | |
1968 | |
1969 (defsetf apply | |
1970 (lambda (&rest args) | |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
3395
diff
changeset
|
1971 ;; disassemble the calling form |
188 | 1972 ;; "(((quote fn) x1 x2 ... xn) val)" (function instead of quote, too) |
1973 (let* ((fnform (car args)) ;functional form | |
1974 (applyargs (append ;arguments "to apply fnform" | |
1975 (apply 'list* (butlast (cdr args))) | |
1976 (last args))) | |
1977 (newupdater nil)) ; its update-fn, if any | |
1978 (if (and (symbolp fnform) | |
1979 (setq newupdater (get fnform :setf-update-fn))) | |
1980 (apply newupdater applyargs) | |
1981 (error "can't `setf' to `%s'" | |
1982 (prin1-to-string fnform))))) | |
1983 "`apply' is a special case for `setf'") | |
1984 | |
1985 | |
1986 (defsetf aref | |
1987 aset | |
1988 "`setf' inversion for `aref'") | |
1989 | |
1990 (defsetf nth | |
1991 setnth | |
1992 "`setf' inversion for `nth'") | |
1993 | |
1994 (defsetf nthcdr | |
1995 setnthcdr | |
1996 "`setf' inversion for `nthcdr'") | |
1997 | |
1998 (defsetf elt | |
1999 setelt | |
2000 "`setf' inversion for `elt'") | |
2001 | |
2002 (defsetf first | |
2003 (lambda (list val) (setnth 0 list val)) | |
2004 "`setf' inversion for `first'") | |
2005 | |
2006 (defsetf second | |
2007 (lambda (list val) (setnth 1 list val)) | |
2008 "`setf' inversion for `second'") | |
2009 | |
2010 (defsetf third | |
2011 (lambda (list val) (setnth 2 list val)) | |
2012 "`setf' inversion for `third'") | |
2013 | |
2014 (defsetf fourth | |
2015 (lambda (list val) (setnth 3 list val)) | |
2016 "`setf' inversion for `fourth'") | |
2017 | |
2018 (defsetf fifth | |
2019 (lambda (list val) (setnth 4 list val)) | |
2020 "`setf' inversion for `fifth'") | |
2021 | |
2022 (defsetf sixth | |
2023 (lambda (list val) (setnth 5 list val)) | |
2024 "`setf' inversion for `sixth'") | |
2025 | |
2026 (defsetf seventh | |
2027 (lambda (list val) (setnth 6 list val)) | |
2028 "`setf' inversion for `seventh'") | |
2029 | |
2030 (defsetf eighth | |
2031 (lambda (list val) (setnth 7 list val)) | |
2032 "`setf' inversion for `eighth'") | |
2033 | |
2034 (defsetf ninth | |
2035 (lambda (list val) (setnth 8 list val)) | |
2036 "`setf' inversion for `ninth'") | |
2037 | |
2038 (defsetf tenth | |
2039 (lambda (list val) (setnth 9 list val)) | |
2040 "`setf' inversion for `tenth'") | |
2041 | |
2042 (defsetf rest | |
2043 (lambda (list val) (setcdr list val)) | |
2044 "`setf' inversion for `rest'") | |
2045 | |
2046 (defsetf car setcar "Replace the car of a cons") | |
2047 | |
2048 (defsetf cdr setcdr "Replace the cdr of a cons") | |
2049 | |
2050 (defsetf caar | |
2051 (lambda (list val) (setcar (nth 0 list) val)) | |
2052 "`setf' inversion for `caar'") | |
2053 | |
2054 (defsetf cadr | |
2055 (lambda (list val) (setcar (cdr list) val)) | |
2056 "`setf' inversion for `cadr'") | |
2057 | |
2058 (defsetf cdar | |
2059 (lambda (list val) (setcdr (car list) val)) | |
2060 "`setf' inversion for `cdar'") | |
2061 | |
2062 (defsetf cddr | |
2063 (lambda (list val) (setcdr (cdr list) val)) | |
2064 "`setf' inversion for `cddr'") | |
2065 | |
2066 (defsetf caaar | |
2067 (lambda (list val) (setcar (caar list) val)) | |
2068 "`setf' inversion for `caaar'") | |
2069 | |
2070 (defsetf caadr | |
2071 (lambda (list val) (setcar (cadr list) val)) | |
2072 "`setf' inversion for `caadr'") | |
2073 | |
2074 (defsetf cadar | |
2075 (lambda (list val) (setcar (cdar list) val)) | |
2076 "`setf' inversion for `cadar'") | |
2077 | |
2078 (defsetf cdaar | |
2079 (lambda (list val) (setcdr (caar list) val)) | |
2080 "`setf' inversion for `cdaar'") | |
2081 | |
2082 (defsetf caddr | |
2083 (lambda (list val) (setcar (cddr list) val)) | |
2084 "`setf' inversion for `caddr'") | |
2085 | |
2086 (defsetf cdadr | |
2087 (lambda (list val) (setcdr (cadr list) val)) | |
2088 "`setf' inversion for `cdadr'") | |
2089 | |
2090 (defsetf cddar | |
2091 (lambda (list val) (setcdr (cdar list) val)) | |
2092 "`setf' inversion for `cddar'") | |
2093 | |
2094 (defsetf cdddr | |
2095 (lambda (list val) (setcdr (cddr list) val)) | |
2096 "`setf' inversion for `cdddr'") | |
2097 | |
2098 (defsetf caaaar | |
2099 (lambda (list val) (setcar (caaar list) val)) | |
2100 "`setf' inversion for `caaaar'") | |
2101 | |
2102 (defsetf caaadr | |
2103 (lambda (list val) (setcar (caadr list) val)) | |
2104 "`setf' inversion for `caaadr'") | |
2105 | |
2106 (defsetf caadar | |
2107 (lambda (list val) (setcar (cadar list) val)) | |
2108 "`setf' inversion for `caadar'") | |
2109 | |
2110 (defsetf cadaar | |
2111 (lambda (list val) (setcar (cdaar list) val)) | |
2112 "`setf' inversion for `cadaar'") | |
2113 | |
2114 (defsetf cdaaar | |
2115 (lambda (list val) (setcdr (caar list) val)) | |
2116 "`setf' inversion for `cdaaar'") | |
2117 | |
2118 (defsetf caaddr | |
2119 (lambda (list val) (setcar (caddr list) val)) | |
2120 "`setf' inversion for `caaddr'") | |
2121 | |
2122 (defsetf cadadr | |
2123 (lambda (list val) (setcar (cdadr list) val)) | |
2124 "`setf' inversion for `cadadr'") | |
2125 | |
2126 (defsetf cdaadr | |
2127 (lambda (list val) (setcdr (caadr list) val)) | |
2128 "`setf' inversion for `cdaadr'") | |
2129 | |
2130 (defsetf caddar | |
2131 (lambda (list val) (setcar (cddar list) val)) | |
2132 "`setf' inversion for `caddar'") | |
2133 | |
2134 (defsetf cdadar | |
2135 (lambda (list val) (setcdr (cadar list) val)) | |
2136 "`setf' inversion for `cdadar'") | |
2137 | |
2138 (defsetf cddaar | |
2139 (lambda (list val) (setcdr (cdaar list) val)) | |
2140 "`setf' inversion for `cddaar'") | |
2141 | |
2142 (defsetf cadddr | |
2143 (lambda (list val) (setcar (cdddr list) val)) | |
2144 "`setf' inversion for `cadddr'") | |
2145 | |
2146 (defsetf cddadr | |
2147 (lambda (list val) (setcdr (cdadr list) val)) | |
2148 "`setf' inversion for `cddadr'") | |
2149 | |
2150 (defsetf cdaddr | |
2151 (lambda (list val) (setcdr (caddr list) val)) | |
2152 "`setf' inversion for `cdaddr'") | |
2153 | |
2154 (defsetf cdddar | |
2155 (lambda (list val) (setcdr (cddar list) val)) | |
2156 "`setf' inversion for `cdddar'") | |
2157 | |
2158 (defsetf cddddr | |
2159 (lambda (list val) (setcdr (cddr list) val)) | |
2160 "`setf' inversion for `cddddr'") | |
2161 | |
2162 (defsetf get put "`setf' inversion for `get' is `put'") | |
2163 | |
2164 (defsetf symbol-function fset | |
2165 "`setf' inversion for `symbol-function' is `fset'") | |
2166 | |
2167 (defsetf symbol-plist setplist | |
2168 "`setf' inversion for `symbol-plist' is `setplist'") | |
2169 | |
2170 (defsetf symbol-value set | |
2171 "`setf' inversion for `symbol-value' is `set'") | |
2172 | |
2173 (defsetf point goto-char | |
2174 "To set (point) to N, use (goto-char N)") | |
2175 | |
2176 ;; how about defsetfing other Emacs forms? | |
2177 | |
2178 ;;; Modify macros | |
2179 ;;; | |
2180 ;;; It could be nice to implement define-modify-macro, but I don't | |
2181 ;;; think it really pays. | |
2182 | |
2183 (defmacro incf (ref &optional delta) | |
2184 "(incf REF [DELTA]) -> increment the g.v. REF by DELTA (default 1)" | |
2185 (if (null delta) | |
2186 (setq delta 1)) | |
2187 (list 'setf ref (list '+ ref delta))) | |
2188 | |
2189 (defmacro decf (ref &optional delta) | |
2190 "(decf REF [DELTA]) -> decrement the g.v. REF by DELTA (default 1)" | |
2191 (if (null delta) | |
2192 (setq delta 1)) | |
2193 (list 'setf ref (list '- ref delta))) | |
2194 | |
2195 (defmacro push (item ref) | |
2196 "(push ITEM REF) -> cons ITEM at the head of the g.v. REF (a list)" | |
2197 (list 'setf ref (list 'cons item ref))) | |
2198 | |
2199 (defmacro pushnew (item ref) | |
2200 "(pushnew ITEM REF): adjoin ITEM at the head of the g.v. REF (a list)" | |
2201 (list 'setf ref (list 'adjoin item ref))) | |
2202 | |
2203 (defmacro pop (ref) | |
2204 "(pop REF) -> (prog1 (car REF) (setf REF (cdr REF)))" | |
2205 (let ((listname (gensym))) | |
2206 (list 'let (list (list listname ref)) | |
2207 (list 'prog1 | |
2208 (list 'car listname) | |
2209 (list 'setf ref (list 'cdr listname)))))) | |
2210 | |
2211 ;;; PSETF | |
2212 ;;; | |
2213 ;;; Psetf is the generalized variable equivalent of psetq. The right | |
2214 ;;; hand sides are evaluated and assigned (via setf) to the left hand | |
2215 ;;; sides. The evaluations are done in an environment where they | |
2216 ;;; appear to occur in parallel. | |
2217 | |
2218 (defmacro psetf (&rest body) | |
2219 "(psetf {var value }...) => nil | |
2220 Like setf, but all the values are computed before any assignment is made." | |
2221 (let ((length (length body))) | |
2222 (cond ((/= (% length 2) 0) | |
2223 (error "psetf needs an even number of arguments, %d given" | |
2224 length)) | |
2225 ((null body) | |
2226 '()) | |
2227 (t | |
2228 (list 'prog1 nil | |
2229 (let ((setfs '()) | |
2230 (bodyforms (reverse body))) | |
2231 (while bodyforms | |
2232 (let* ((value (car bodyforms)) | |
2233 (place (cadr bodyforms))) | |
2234 (setq bodyforms (cddr bodyforms)) | |
2235 (if (null setfs) | |
2236 (setq setfs (list 'setf place value)) | |
2237 (setq setfs (list 'setf place | |
2238 (list 'prog1 value | |
2239 setfs)))))) | |
2240 setfs)))))) | |
2241 | |
2242 ;;; SHIFTF and ROTATEF | |
2243 ;;; | |
2244 | |
2245 (defmacro shiftf (&rest forms) | |
2246 "(shiftf PLACE1 PLACE2... NEWVALUE) | |
2247 Set PLACE1 to PLACE2, PLACE2 to PLACE3... | |
2248 Each PLACE is set to the old value of the following PLACE, | |
2249 and the last PLACE is set to the value NEWVALUE. | |
2250 Returns the old value of PLACE1." | |
2251 (unless (> (length forms) 1) | |
2252 (error "`shiftf' needs more than one argument")) | |
2253 (let ((places (butlast forms)) | |
2254 (newvalue (car (last forms)))) | |
2255 ;; the places are accessed to fresh symbols | |
2256 (multiple-value-bind | |
2257 (bindings newsyms) | |
2258 (pair-with-newsyms places) | |
2259 (list 'let bindings | |
2260 (cons 'setf | |
2261 (zip-lists places | |
2262 (append (cdr newsyms) (list newvalue)))) | |
2263 (car newsyms))))) | |
2264 | |
2265 (defmacro rotatef (&rest places) | |
2266 "(rotatef PLACE...) sets each PLACE to the old value of the following PLACE. | |
2267 The last PLACE is set to the old value of the first PLACE. | |
2268 Thus, the values rotate through the PLACEs. Returns nil." | |
2269 (if (null places) | |
2270 nil | |
2271 (multiple-value-bind | |
2272 (bindings newsyms) | |
2273 (pair-with-newsyms places) | |
2274 (list | |
2275 'let bindings | |
2276 (cons 'setf | |
2277 (zip-lists places | |
2278 (append (cdr newsyms) (list (car newsyms))))) | |
2279 nil)))) | |
2280 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2281 ;;; GETF, REMF, and REMPROP |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2282 ;;; |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2283 |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2284 (defun getf (place indicator &optional default) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2285 "Return PLACE's PROPNAME property, or DEFAULT if not present." |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2286 (while (and place (not (eq (car place) indicator))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2287 (setq place (cdr (cdr place)))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2288 (if place |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2289 (car (cdr place)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2290 default)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2291 |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2292 (defmacro getf$setf$method (place indicator default &rest newval) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2293 "SETF method for GETF. Not for public use." |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2294 (case (length newval) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2295 (0 (setq newval default default nil)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2296 (1 (setq newval (car newval))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2297 (t (error "Wrong number of arguments to (setf (getf ...)) form"))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2298 (let ((psym (gentemp)) (isym (gentemp)) (vsym (gentemp))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2299 (list 'let (list (list psym place) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2300 (list isym indicator) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2301 (list vsym newval)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2302 (list 'while |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2303 (list 'and psym |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2304 (list 'not |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2305 (list 'eq (list 'car psym) isym))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2306 (list 'setq psym (list 'cdr (list 'cdr psym)))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2307 (list 'if psym |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2308 (list 'setcar (list 'cdr psym) vsym) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2309 (list 'setf place |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2310 (list 'nconc place (list 'list isym newval)))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2311 vsym))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2312 |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2313 (defsetf getf |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2314 getf$setf$method) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2315 |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2316 (defmacro remf (place indicator) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2317 "Remove from the property list at PLACE its PROPNAME property. |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2318 Returns non-nil if and only if the property existed." |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2319 (let ((psym (gentemp)) (isym (gentemp))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2320 (list 'let (list (list psym place) (list isym indicator)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2321 (list 'cond |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2322 (list (list 'eq isym (list 'car psym)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2323 (list 'setf place (list 'cdr (list 'cdr psym))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2324 t) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2325 (list t |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2326 (list 'setq psym (list 'cdr psym)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2327 (list 'while |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2328 (list 'and (list 'cdr psym) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2329 (list 'not |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2330 (list 'eq (list 'car (list 'cdr psym)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2331 isym))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2332 (list 'setq psym (list 'cdr (list 'cdr psym)))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2333 (list 'cond |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2334 (list (list 'cdr psym) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2335 (list 'setcdr psym |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2336 (list 'cdr |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2337 (list 'cdr (list 'cdr psym)))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2338 t))))))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2339 |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2340 (defun remprop (symbol indicator) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2341 "Remove SYMBOL's PROPNAME property, returning non-nil if it was present." |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2342 (remf (symbol-plist symbol) indicator)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2343 |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2344 |
188 | 2345 ;;;; STRUCTS |
2346 ;;;; This file provides the structures mechanism. See the | |
2347 ;;;; documentation for Common-Lisp's defstruct. Mine doesn't | |
2348 ;;;; implement all the functionality of the standard, although some | |
2349 ;;;; more could be grafted if so desired. More details along with | |
2350 ;;;; the code. | |
2351 ;;;; | |
2352 ;;;; | |
2353 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 | |
2354 ;;;; (quiroz@cs.rochester.edu) | |
2355 | |
2356 | |
2357 (defkeyword :include "Syntax of `defstruct'") | |
2358 (defkeyword :named "Syntax of `defstruct'") | |
2359 (defkeyword :conc-name "Syntax of `defstruct'") | |
2360 (defkeyword :copier "Syntax of `defstruct'") | |
2361 (defkeyword :predicate "Syntax of `defstruct'") | |
2362 (defkeyword :print-function "Syntax of `defstruct'") | |
2363 (defkeyword :type "Syntax of `defstruct'") | |
2364 (defkeyword :initial-offset "Syntax of `defstruct'") | |
2365 | |
2366 (defkeyword :structure-doc "Documentation string for a structure.") | |
2367 (defkeyword :structure-slotsn "Number of slots in structure") | |
2368 (defkeyword :structure-slots "List of the slot's names") | |
2369 (defkeyword :structure-indices "List of (KEYWORD-NAME . INDEX)") | |
2370 (defkeyword :structure-initforms "List of (KEYWORD-NAME . INITFORM)") | |
2371 (defkeyword :structure-includes | |
2372 "() or list of a symbol, that this struct includes") | |
2373 (defkeyword :structure-included-in | |
2374 "List of the structs that include this") | |
2375 | |
2376 | |
2377 (defmacro defstruct (&rest args) | |
2378 "(defstruct NAME [DOC-STRING] . SLOTS) define NAME as structure type. | |
2379 NAME must be a symbol, the name of the new structure. It could also | |
2380 be a list (NAME . OPTIONS). | |
2381 | |
2382 Each option is either a symbol, or a list of a keyword symbol taken from the | |
2383 list \{:conc-name, :copier, :constructor, :predicate, :include, | |
2384 :print-function, :type, :initial-offset\}. The meanings of these are as in | |
2385 CLtL, except that no BOA-constructors are provided, and the options | |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
3395
diff
changeset
|
2386 \{:print-function, :type, :initial-offset\} are ignored quietly. All these |
188 | 2387 structs are named, in the sense that their names can be used for type |
2388 discrimination. | |
2389 | |
2390 The DOC-STRING is established as the `structure-doc' property of NAME. | |
2391 | |
2392 The SLOTS are one or more of the following: | |
2393 SYMBOL -- meaning the SYMBOL is the name of a SLOT of NAME | |
2394 list of SYMBOL and VALUE -- meaning that VALUE is the initial value of | |
2395 the slot. | |
2396 `defstruct' defines functions `make-NAME', `NAME-p', `copy-NAME' for the | |
2397 structure, and functions with the same name as the slots to access | |
2398 them. `setf' of the accessors sets their values." | |
2399 (multiple-value-bind | |
2400 (name options docstring slotsn slots initlist) | |
2401 (parse$defstruct$args args) | |
2402 ;; Names for the member functions come from the options. The | |
2403 ;; slots* stuff collects info about the slots declared explicitly. | |
2404 (multiple-value-bind | |
2405 (conc-name constructor copier predicate | |
2406 moreslotsn moreslots moreinits included) | |
2407 (parse$defstruct$options name options slots) | |
2408 ;; The moreslots* stuff refers to slots gained as a consequence | |
2409 ;; of (:include clauses). -- Oct 89: Only one :include tolerated | |
2410 (when (and (numberp moreslotsn) | |
2411 (> moreslotsn 0)) | |
2412 (setf slotsn (+ slotsn moreslotsn)) | |
2413 (setf slots (append moreslots slots)) | |
2414 (setf initlist (append moreinits initlist))) | |
2415 (unless (> slotsn 0) | |
2416 (error "%s needs at least one slot" | |
2417 (prin1-to-string name))) | |
2418 (let ((dups (duplicate-symbols-p slots))) | |
2419 (when dups | |
2420 (error "`%s' are duplicates" | |
2421 (prin1-to-string dups)))) | |
2422 (setq initlist (simplify$inits slots initlist)) | |
2423 (let (properties functions keywords accessors alterators returned) | |
2424 ;; compute properties of NAME | |
2425 (setq properties | |
2426 (append | |
2427 (list | |
2428 (list 'put (list 'quote name) :structure-doc | |
2429 docstring) | |
2430 (list 'put (list 'quote name) :structure-slotsn | |
2431 slotsn) | |
2432 (list 'put (list 'quote name) :structure-slots | |
2433 (list 'quote slots)) | |
2434 (list 'put (list 'quote name) :structure-initforms | |
2435 (list 'quote initlist)) | |
2436 (list 'put (list 'quote name) :structure-indices | |
2437 (list 'quote (extract$indices initlist)))) | |
2438 ;; If this definition :includes another defstruct, | |
2439 ;; modify both property lists. | |
2440 (cond (included | |
2441 (list | |
2442 (list 'put | |
2443 (list 'quote name) | |
2444 :structure-includes | |
2445 (list 'quote included)) | |
2446 (list 'pushnew | |
2447 (list 'quote name) | |
2448 (list 'get (list 'quote (car included)) | |
2449 :structure-included-in)))) | |
2450 (t | |
2451 (list | |
2452 (let ((old (gensym))) | |
2453 (list 'let | |
2454 (list (list old | |
2455 (list 'car | |
2456 (list 'get | |
2457 (list 'quote name) | |
2458 :structure-includes)))) | |
2459 (list 'when old | |
2460 (list 'put | |
2461 old | |
2462 :structure-included-in | |
2463 (list 'delq | |
2464 (list 'quote name) | |
2465 ;; careful with destructive | |
2466 ;;manipulation! | |
2467 (list | |
2468 'append | |
2469 (list | |
2470 'get | |
2471 old | |
2472 :structure-included-in) | |
2473 '()) | |
2474 ))))) | |
2475 (list 'put | |
2476 (list 'quote name) | |
2477 :structure-includes | |
2478 '())))) | |
2479 ;; If this definition used to be :included in another, warn | |
2480 ;; that things make break. On the other hand, the redefinition | |
2481 ;; may be trivial, so don't call it an error. | |
2482 (let ((old (gensym))) | |
2483 (list | |
2484 (list 'let | |
2485 (list (list old (list 'get | |
2486 (list 'quote name) | |
2487 :structure-included-in))) | |
2488 (list 'when old | |
2489 (list 'message | |
2490 "`%s' redefined. Should redefine `%s'?" | |
2491 (list 'quote name) | |
2492 (list 'prin1-to-string old)))))))) | |
2493 | |
2494 ;; Compute functions associated with NAME. This is not | |
2495 ;; handling BOA constructors yet, but here would be the place. | |
2496 (setq functions | |
2497 (list | |
2498 (list 'fset (list 'quote constructor) | |
2499 (list 'function | |
2500 (list 'lambda (list '&rest 'args) | |
2501 (list 'make$structure$instance | |
2502 (list 'quote name) | |
2503 'args)))) | |
2504 (list 'fset (list 'quote copier) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2505 (list 'function 'copy-sequence)) |
188 | 2506 (let ((typetag (gensym))) |
2507 (list 'fset (list 'quote predicate) | |
2508 (list | |
2509 'function | |
2510 (list | |
2511 'lambda (list 'thing) | |
2512 (list 'and | |
2513 (list 'vectorp 'thing) | |
2514 (list 'let | |
2515 (list (list typetag | |
2516 (list 'elt 'thing 0))) | |
2517 (list 'or | |
2518 (list | |
2519 'and | |
2520 (list 'eq | |
2521 typetag | |
2522 (list 'quote name)) | |
2523 (list '= | |
2524 (list 'length 'thing) | |
2525 (1+ slotsn))) | |
2526 (list | |
2527 'memq | |
2528 typetag | |
2529 (list 'get | |
2530 (list 'quote name) | |
2531 :structure-included-in)))))) | |
2532 ))))) | |
2533 ;; compute accessors for NAME's slots | |
2534 (multiple-value-setq | |
2535 (accessors alterators keywords) | |
2536 (build$accessors$for name conc-name predicate slots slotsn)) | |
2537 ;; generate returned value -- not defined by the standard | |
2538 (setq returned | |
2539 (list | |
2540 (cons 'vector | |
2541 (mapcar | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2542 (function (lambda (x) (list 'quote x))) |
188 | 2543 (cons name slots))))) |
2544 ;; generate code | |
2545 (cons 'progn | |
2546 (nconc properties functions keywords | |
2547 accessors alterators returned)))))) | |
2548 | |
2549 (defun parse$defstruct$args (args) | |
2550 "(parse$defstruct$args ARGS) => NAME OPTIONS DOCSTRING SLOTSN SLOTS INITLIST | |
2551 NAME=symbol, OPTIONS=list of, DOCSTRING=string, SLOTSN=count of slots, | |
2552 SLOTS=list of their names, INITLIST=alist (keyword . initform)." | |
2553 (let (name ;args=(symbol...) or ((symbol...)...) | |
2554 options ;args=((symbol . options) ...) | |
2555 (docstring "") ;args=(head docstring . slotargs) | |
2556 slotargs ;second or third cdr of args | |
2557 (slotsn 0) ;number of slots | |
2558 (slots '()) ;list of slot names | |
2559 (initlist '())) ;list of (slot keyword . initform) | |
2560 ;; extract name and options | |
2561 (cond ((symbolp (car args)) ;simple name | |
2562 (setq name (car args) | |
2563 options '())) | |
2564 ((and (listp (car args)) ;(name . options) | |
2565 (symbolp (caar args))) | |
2566 (setq name (caar args) | |
2567 options (cdar args))) | |
2568 (t | |
2569 (error "first arg to `defstruct' must be symbol or (symbol ...)"))) | |
2570 (setq slotargs (cdr args)) | |
2571 ;; is there a docstring? | |
2572 (when (stringp (car slotargs)) | |
2573 (setq docstring (car slotargs) | |
2574 slotargs (cdr slotargs))) | |
2575 ;; now for the slots | |
2576 (multiple-value-bind | |
2577 (slotsn slots initlist) | |
2578 (process$slots slotargs) | |
2579 (values name options docstring slotsn slots initlist)))) | |
2580 | |
2581 (defun process$slots (slots) | |
2582 "(process$slots SLOTS) => SLOTSN SLOTSLIST INITLIST | |
2583 Converts a list of symbols or lists of symbol and form into the last 3 | |
2584 values returned by PARSE$DEFSTRUCT$ARGS." | |
2585 (let ((slotsn (length slots)) ;number of slots | |
2586 slotslist ;(slot1 slot2 ...) | |
2587 initlist) ;((:slot1 . init1) ...) | |
2588 (do* | |
2589 ((ptr slots (cdr ptr)) | |
2590 (this (car ptr) (car ptr))) | |
2591 ((endp ptr)) | |
2592 (cond ((symbolp this) | |
2593 (setq slotslist (cons this slotslist)) | |
2594 (setq initlist (acons (keyword-of this) nil initlist))) | |
2595 ((and (listp this) | |
2596 (symbolp (car this))) | |
2597 (let ((name (car this)) | |
2598 (form (cadr this))) | |
2599 ;; this silently ignores any slot options. bad... | |
2600 (setq slotslist (cons name slotslist)) | |
2601 (setq initlist (acons (keyword-of name) form initlist)))) | |
2602 (t | |
2603 (error "slot should be symbol or (symbol ...), not `%s'" | |
2604 (prin1-to-string this))))) | |
2605 (values slotsn (nreverse slotslist) (nreverse initlist)))) | |
2606 | |
2607 (defun parse$defstruct$options (name options slots) | |
2608 "(parse$defstruct$options name OPTIONS SLOTS) => many values | |
2609 A defstruct named NAME, with options list OPTIONS, has already slots SLOTS. | |
2610 Parse the OPTIONS and return the updated form of the struct's slots and other | |
2611 information. The values returned are: | |
2612 | |
2613 CONC-NAME is the string to use as prefix/suffix in the methods, | |
2614 CONST is the name of the official constructor, | |
2615 COPIER is the name of the structure copier, | |
2616 PRED is the name of the type predicate, | |
2617 MORESLOTSN is the number of slots added by :include, | |
2618 MORESLOTS is the list of slots added by :include, | |
2619 MOREINITS is the list of initialization forms added by :include, | |
2620 INCLUDED is nil, or the list of the symbol added by :include" | |
2621 (let* ((namestring (symbol-name name)) | |
2622 ;; to build the return values | |
2623 (conc-name (concat namestring "-")) | |
2624 (const (intern (concat "make-" namestring))) | |
2625 (copier (intern (concat "copy-" namestring))) | |
2626 (pred (intern (concat namestring "-p"))) | |
2627 (moreslotsn 0) | |
2628 (moreslots '()) | |
2629 (moreinits '()) | |
2630 ;; auxiliaries | |
2631 option-head ;When an option is not a plain | |
2632 option-second ; keyword, it must be a list of | |
2633 option-rest ; the form (head second . rest) | |
2634 these-slotsn ;When :include is found, the | |
2635 these-slots ; info about the included | |
2636 these-inits ; structure is added here. | |
2637 included ;NIL or (list INCLUDED) | |
2638 ) | |
2639 ;; Values above are the defaults. Now we read the options themselves | |
2640 (dolist (option options) | |
2641 ;; 2 cases arise, as options must be a keyword or a list | |
2642 (cond | |
2643 ((keywordp option) | |
2644 (case option | |
2645 (:named | |
2646 ) ;ignore silently | |
2647 (t | |
2648 (error "can't recognize option `%s'" | |
2649 (prin1-to-string option))))) | |
2650 ((and (listp option) | |
2651 (keywordp (setq option-head (car option)))) | |
2652 (setq option-second (second option)) | |
2653 (setq option-rest (nthcdr 2 option)) | |
2654 (case option-head | |
2655 (:conc-name | |
2656 (setq conc-name | |
2657 (cond | |
2658 ((stringp option-second) | |
2659 option-second) | |
2660 ((null option-second) | |
2661 "") | |
2662 (t | |
2663 (error "`%s' is invalid as `conc-name'" | |
2664 (prin1-to-string option-second)))))) | |
2665 (:copier | |
2666 (setq copier | |
2667 (cond | |
2668 ((and (symbolp option-second) | |
2669 (null option-rest)) | |
2670 option-second) | |
2671 (t | |
2672 (error "can't recognize option `%s'" | |
2673 (prin1-to-string option)))))) | |
2674 | |
2675 (:constructor ;no BOA-constructors allowed | |
2676 (setq const | |
2677 (cond | |
2678 ((and (symbolp option-second) | |
2679 (null option-rest)) | |
2680 option-second) | |
2681 (t | |
2682 (error "can't recognize option `%s'" | |
2683 (prin1-to-string option)))))) | |
2684 (:predicate | |
2685 (setq pred | |
2686 (cond | |
2687 ((and (symbolp option-second) | |
2688 (null option-rest)) | |
2689 option-second) | |
2690 (t | |
2691 (error "can't recognize option `%s'" | |
2692 (prin1-to-string option)))))) | |
2693 (:include | |
2694 (unless (symbolp option-second) | |
2695 (error "arg to `:include' should be a symbol, not `%s'" | |
2696 (prin1-to-string option-second))) | |
2697 (setq these-slotsn (get option-second :structure-slotsn) | |
2698 these-slots (get option-second :structure-slots) | |
2699 these-inits (get option-second :structure-initforms)) | |
2700 (unless (and (numberp these-slotsn) | |
2701 (> these-slotsn 0)) | |
2702 (error "`%s' is not a valid structure" | |
2703 (prin1-to-string option-second))) | |
2704 (if included | |
2705 (error "`%s' already includes `%s', can't include `%s' too" | |
2706 name (car included) option-second) | |
2707 (push option-second included)) | |
2708 (multiple-value-bind | |
2709 (xtra-slotsn xtra-slots xtra-inits) | |
2710 (process$slots option-rest) | |
2711 (when (> xtra-slotsn 0) | |
2712 (dolist (xslot xtra-slots) | |
2713 (unless (memq xslot these-slots) | |
2714 (error "`%s' is not a slot of `%s'" | |
2715 (prin1-to-string xslot) | |
2716 (prin1-to-string option-second)))) | |
2717 (setq these-inits (append xtra-inits these-inits))) | |
2718 (setq moreslotsn (+ moreslotsn these-slotsn)) | |
2719 (setq moreslots (append these-slots moreslots)) | |
2720 (setq moreinits (append these-inits moreinits)))) | |
2721 ((:print-function :type :initial-offset) | |
2722 ) ;ignore silently | |
2723 (t | |
2724 (error "can't recognize option `%s'" | |
2725 (prin1-to-string option))))) | |
2726 (t | |
2727 (error "can't recognize option `%s'" | |
2728 (prin1-to-string option))))) | |
2729 ;; Return values found | |
2730 (values conc-name const copier pred | |
2731 moreslotsn moreslots moreinits | |
2732 included))) | |
2733 | |
2734 (defun simplify$inits (slots initlist) | |
2735 "(simplify$inits SLOTS INITLIST) => new INITLIST | |
2736 Removes from INITLIST - an ALIST - any shadowed bindings." | |
2737 (let ((result '()) ;built here | |
2738 key ;from the slot | |
2739 ) | |
2740 (dolist (slot slots) | |
2741 (setq key (keyword-of slot)) | |
2742 (setq result (acons key (cdr (assoc key initlist)) result))) | |
2743 (nreverse result))) | |
2744 | |
2745 (defun extract$indices (initlist) | |
2746 "(extract$indices INITLIST) => indices list | |
2747 Kludge. From a list of pairs (keyword . form) build a list of pairs | |
2748 of the form (keyword . position in list from 0). Useful to precompute | |
2749 some of the work of MAKE$STRUCTURE$INSTANCE." | |
2750 (let ((result '()) | |
2751 (index 0)) | |
2752 (dolist (entry initlist (nreverse result)) | |
2753 (setq result (acons (car entry) index result) | |
2754 index (+ index 1))))) | |
2755 | |
2756 (defun build$accessors$for (name conc-name predicate slots slotsn) | |
2757 "(build$accessors$for NAME PREDICATE SLOTS SLOTSN) => FSETS DEFSETFS KWDS | |
2758 Generate the code for accesors and defsetfs of a structure called | |
2759 NAME, whose slots are SLOTS. Also, establishes the keywords for the | |
2760 slots names." | |
2761 (do ((i 0 (1+ i)) | |
2762 (accessors '()) | |
2763 (alterators '()) | |
2764 (keywords '()) | |
2765 (canonic "")) ;slot name with conc-name prepended | |
2766 ((>= i slotsn) | |
2767 (values | |
2768 (nreverse accessors) (nreverse alterators) (nreverse keywords))) | |
2769 (setq canonic (intern (concat conc-name (symbol-name (nth i slots))))) | |
2770 (setq accessors | |
2771 (cons | |
2772 (list 'fset (list 'quote canonic) | |
2773 (list 'function | |
2774 (list 'lambda (list 'object) | |
2775 (list 'cond | |
2776 (list (list predicate 'object) | |
2777 (list 'aref 'object (1+ i))) | |
2778 (list 't | |
2779 (list 'error | |
2780 "`%s' is not a struct %s" | |
2781 (list 'prin1-to-string | |
2782 'object) | |
2783 (list 'prin1-to-string | |
2784 (list 'quote | |
2785 name)))))))) | |
2786 accessors)) | |
2787 (setq alterators | |
2788 (cons | |
2789 (list 'defsetf canonic | |
2790 (list 'lambda (list 'object 'newval) | |
2791 (list 'cond | |
2792 (list (list predicate 'object) | |
2793 (list 'aset 'object (1+ i) 'newval)) | |
2794 (list 't | |
2795 (list 'error | |
2796 "`%s' not a `%s'" | |
2797 (list 'prin1-to-string | |
2798 'object) | |
2799 (list 'prin1-to-string | |
2800 (list 'quote | |
2801 name))))))) | |
2802 alterators)) | |
2803 (setq keywords | |
2804 (cons (list 'defkeyword (keyword-of (nth i slots))) | |
2805 keywords)))) | |
2806 | |
2807 (defun make$structure$instance (name args) | |
2808 "(make$structure$instance NAME ARGS) => new struct NAME | |
2809 A struct of type NAME is created, some slots might be initialized | |
2810 according to ARGS (the &rest argument of MAKE-name)." | |
2811 (unless (symbolp name) | |
2812 (error "`%s' is not a possible name for a structure" | |
2813 (prin1-to-string name))) | |
2814 (let ((initforms (get name :structure-initforms)) | |
2815 (slotsn (get name :structure-slotsn)) | |
2816 (indices (get name :structure-indices)) | |
2817 initalist ;pairlis'd on initforms | |
2818 initializers ;definitive initializers | |
2819 ) | |
2820 ;; check sanity of the request | |
2821 (unless (and (numberp slotsn) | |
2822 (> slotsn 0)) | |
2823 (error "`%s' is not a defined structure" | |
2824 (prin1-to-string name))) | |
2825 (unless (evenp (length args)) | |
2826 (error "slot initializers `%s' not of even length" | |
2827 (prin1-to-string args))) | |
2828 ;; analyze the initializers provided by the call | |
2829 (multiple-value-bind | |
2830 (speckwds specvals) ;keywords and values given | |
2831 (unzip-list args) ; by the user | |
2832 ;; check that all the arguments are introduced by keywords | |
2833 (unless (every (function keywordp) speckwds) | |
2834 (error "all of the names in `%s' should be keywords" | |
2835 (prin1-to-string speckwds))) | |
2836 ;; check that all the keywords are known | |
2837 (dolist (kwd speckwds) | |
2838 (unless (numberp (cdr (assoc kwd indices))) | |
2839 (error "`%s' is not a valid slot name for %s" | |
2840 (prin1-to-string kwd) (prin1-to-string name)))) | |
2841 ;; update initforms | |
2842 (setq initalist | |
2843 (pairlis speckwds | |
2844 (do* ;;protect values from further evaluation | |
2845 ((ptr specvals (cdr ptr)) | |
2846 (val (car ptr) (car ptr)) | |
2847 (result '())) | |
2848 ((endp ptr) (nreverse result)) | |
2849 (setq result | |
2850 (cons (list 'quote val) | |
2851 result))) | |
2852 (copy-sequence initforms))) | |
2853 ;; compute definitive initializers | |
2854 (setq initializers | |
2855 (do* ;;gather the values of the most definitive forms | |
2856 ((ptr indices (cdr ptr)) | |
2857 (key (caar ptr) (caar ptr)) | |
2858 (result '())) | |
2859 ((endp ptr) (nreverse result)) | |
2860 (setq result | |
2861 (cons (eval (cdr (assoc key initalist))) result)))) | |
2862 ;; do real initialization | |
2863 (apply (function vector) | |
2864 (cons name initializers))))) | |
2865 | |
2866 ;;;; end of cl-structs.el | |
2867 | |
2868 ;;; For lisp-interaction mode, so that multiple values can be seen when passed | |
2869 ;;; back. Lies every now and then... | |
2870 | |
2871 (defvar - nil "form currently under evaluation") | |
2872 (defvar + nil "previous -") | |
2873 (defvar ++ nil "previous +") | |
2874 (defvar +++ nil "previous ++") | |
2875 (defvar / nil "list of values returned by +") | |
2876 (defvar // nil "list of values returned by ++") | |
2877 (defvar /// nil "list of values returned by +++") | |
2878 (defvar * nil "(first) value of +") | |
2879 (defvar ** nil "(first) value of ++") | |
2880 (defvar *** nil "(first) value of +++") | |
2881 | |
2882 (defun cl-eval-print-last-sexp () | |
2883 "Evaluate sexp before point; print value\(s\) into current buffer. | |
2884 If the evaled form returns multiple values, they are shown one to a line. | |
2885 The variables -, +, ++, +++, *, **, ***, /, //, /// have their usual meaning. | |
2886 | |
2887 It clears the multiple-value passing mechanism, and does not pass back | |
2888 multiple values. Use this only if you are debugging cl.el and understand well | |
2889 how the multiple-value stuff works, because it can be fooled into believing | |
2890 that multiple values have been returned when they actually haven't, for | |
2891 instance | |
2892 \(identity \(values nil 1\)\) | |
2893 However, even when this fails, you can trust the first printed value to be | |
2894 \(one of\) the returned value\(s\)." | |
2895 (interactive) | |
2896 ;; top level call, can reset mvalues | |
2897 (setq *mvalues-count* nil | |
2898 *mvalues-values* nil) | |
2899 (setq - (car (read-from-string | |
2900 (buffer-substring | |
2901 (let ((stab (syntax-table))) | |
2902 (unwind-protect | |
2903 (save-excursion | |
2904 (set-syntax-table emacs-lisp-mode-syntax-table) | |
2905 (forward-sexp -1) | |
2906 (point)) | |
2907 (set-syntax-table stab))) | |
2908 (point))))) | |
2909 (setq *** ** | |
2910 ** * | |
2911 * (eval -)) | |
2912 (setq /// // | |
2913 // / | |
2914 / *mvalues-values*) | |
2915 (setq +++ ++ | |
2916 ++ + | |
2917 + -) | |
2918 (cond ((or (null *mvalues-count*) ;mvalues mechanism not used | |
2919 (not (eq * (car *mvalues-values*)))) | |
2920 (print * (current-buffer))) | |
2921 ((null /) ;no values returned | |
2922 (terpri (current-buffer))) | |
2923 (t ;more than zero mvalues | |
2924 (terpri (current-buffer)) | |
2925 (mapcar (function (lambda (value) | |
2926 (prin1 value (current-buffer)) | |
2927 (terpri (current-buffer)))) | |
2928 /))) | |
2929 (setq *mvalues-count* nil ;make sure | |
2930 *mvalues-values* nil)) | |
2931 | |
2932 ;;;; More LISTS functions | |
2933 ;;;; | |
2934 | |
2935 ;;; Some mapping functions on lists, commonly useful. | |
2936 ;;; They take no extra sequences, to go along with Emacs Lisp's MAPCAR. | |
2937 | |
2938 (defun mapc (function list) | |
2939 "(MAPC FUNCTION LIST) => LIST | |
2940 Apply FUNCTION to each element of LIST, return LIST. | |
2941 Like mapcar, but called only for effect." | |
2942 (let ((args list)) | |
2943 (while args | |
2944 (funcall function (car args)) | |
2945 (setq args (cdr args)))) | |
2946 list) | |
2947 | |
2948 (defun maplist (function list) | |
2949 "(MAPLIST FUNCTION LIST) => list'ed results of FUNCTION on cdrs of LIST | |
2950 Apply FUNCTION to successive sublists of LIST, return the list of the results" | |
2951 (let ((args list) | |
2952 results '()) | |
2953 (while args | |
2954 (setq results (cons (funcall function args) results) | |
2955 args (cdr args))) | |
2956 (nreverse results))) | |
2957 | |
2958 (defun mapl (function list) | |
2959 "(MAPL FUNCTION LIST) => LIST | |
2960 Apply FUNCTION to successive cdrs of LIST, return LIST. | |
2961 Like maplist, but called only for effect." | |
2962 (let ((args list)) | |
2963 (while args | |
2964 (funcall function args) | |
2965 (setq args (cdr args))) | |
2966 list)) | |
2967 | |
2968 (defun mapcan (function list) | |
2969 "(MAPCAN FUNCTION LIST) => nconc'd results of FUNCTION on LIST | |
2970 Apply FUNCTION to each element of LIST, nconc the results. | |
2971 Beware: nconc destroys its first argument! See copy-list." | |
2972 (let ((args list) | |
2973 (results '())) | |
2974 (while args | |
2975 (setq results (nconc (funcall function (car args)) results) | |
2976 args (cdr args))) | |
2977 (nreverse results))) | |
2978 | |
2979 (defun mapcon (function list) | |
2980 "(MAPCON FUNCTION LIST) => nconc'd results of FUNCTION on cdrs of LIST | |
2981 Apply FUNCTION to successive sublists of LIST, nconc the results. | |
2982 Beware: nconc destroys its first argument! See copy-list." | |
2983 (let ((args list) | |
2984 (results '())) | |
2985 (while args | |
2986 (setq results (nconc (funcall function args) results) | |
2987 args (cdr args))) | |
2988 (nreverse results))) | |
2989 | |
2990 ;;; Copiers | |
2991 | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
2992 (defsubst copy-list (list) |
188 | 2993 "Build a copy of LIST" |
2994 (append list '())) | |
2995 | |
2996 (defun copy-tree (tree) | |
2997 "Build a copy of the tree of conses TREE | |
2998 The argument is a tree of conses, it is recursively copied down to | |
2999 non conses. Circularity and sharing of substructure are not | |
3000 necessarily preserved." | |
3001 (if (consp tree) | |
3002 (cons (copy-tree (car tree)) | |
3003 (copy-tree (cdr tree))) | |
3004 tree)) | |
3005 | |
3006 ;;; reversals, and destructive manipulations of a list's spine | |
3007 | |
3008 (defun revappend (x y) | |
3009 "does what (append (reverse X) Y) would, only faster" | |
3010 (if (endp x) | |
3011 y | |
3012 (revappend (cdr x) (cons (car x) y)))) | |
3013 | |
3014 (defun nreconc (x y) | |
3015 "does (nconc (nreverse X) Y) would, only faster | |
3016 Destructive on X, be careful." | |
3017 (if (endp x) | |
3018 y | |
3019 ;; reuse the first cons of x, making it point to y | |
3020 (nreconc (cdr x) (prog1 x (rplacd x y))))) | |
3021 | |
3022 (defun nbutlast (list &optional n) | |
3023 "Side-effected LIST truncated N+1 conses from the end. | |
3024 This is the destructive version of BUTLAST. Returns () and does not | |
3025 modify the LIST argument if the length of the list is not at least N." | |
3026 (when (null n) (setf n 1)) | |
3027 (let ((length (list-length list))) | |
3028 (cond ((null length) | |
3029 list) | |
3030 ((< length n) | |
3031 '()) | |
3032 (t | |
3033 (setnthcdr (- length n) list nil) | |
3034 list)))) | |
3035 | |
3036 ;;; Substitutions | |
3037 | |
3038 (defun subst (new old tree) | |
3039 "NEW replaces OLD in a copy of TREE | |
3040 Uses eql for the test." | |
3041 (subst-if new (function (lambda (x) (eql x old))) tree)) | |
3042 | |
3043 (defun subst-if-not (new test tree) | |
3044 "NEW replaces any subtree or leaf that fails TEST in a copy of TREE" | |
3045 ;; (subst-if new (function (lambda (x) (not (funcall test x)))) tree) | |
3046 (cond ((not (funcall test tree)) | |
3047 new) | |
3048 ((atom tree) | |
3049 tree) | |
3050 (t ;no match so far | |
3051 (let ((head (subst-if-not new test (car tree))) | |
3052 (tail (subst-if-not new test (cdr tree)))) | |
3053 ;; If nothing changed, return originals. Else use the new | |
3054 ;; components to assemble a new tree. | |
3055 (if (and (eql head (car tree)) | |
3056 (eql tail (cdr tree))) | |
3057 tree | |
3058 (cons head tail)))))) | |
3059 | |
3060 (defun subst-if (new test tree) | |
3061 "NEW replaces any subtree or leaf that satisfies TEST in a copy of TREE" | |
3062 (cond ((funcall test tree) | |
3063 new) | |
3064 ((atom tree) | |
3065 tree) | |
3066 (t ;no match so far | |
3067 (let ((head (subst-if new test (car tree))) | |
3068 (tail (subst-if new test (cdr tree)))) | |
3069 ;; If nothing changed, return originals. Else use the new | |
3070 ;; components to assemble a new tree. | |
3071 (if (and (eql head (car tree)) | |
3072 (eql tail (cdr tree))) | |
3073 tree | |
3074 (cons head tail)))))) | |
3075 | |
3076 (defun sublis (alist tree) | |
3077 "Use association list ALIST to modify a copy of TREE | |
3078 If a subtree or leaf of TREE is a key in ALIST, it is replaced by the | |
3079 associated value. Not exactly Common Lisp, but close in spirit and | |
3080 compatible with the native Emacs Lisp ASSOC, which uses EQUAL." | |
3081 (let ((toplevel (assoc tree alist))) | |
3082 (cond (toplevel ;Bingo at top | |
3083 (cdr toplevel)) | |
3084 ((atom tree) ;Give up on this | |
3085 tree) | |
3086 (t | |
3087 (let ((head (sublis alist (car tree))) | |
3088 (tail (sublis alist (cdr tree)))) | |
3089 (if (and (eql head (car tree)) | |
3090 (eql tail (cdr tree))) | |
3091 tree | |
3092 (cons head tail))))))) | |
3093 | |
3094 (defun member-if (predicate list) | |
3095 "PREDICATE is applied to the members of LIST. As soon as one of them | |
3096 returns true, that tail of the list if returned. Else NIL." | |
3097 (catch 'found-member-if | |
3098 (while (not (endp list)) | |
3099 (if (funcall predicate (car list)) | |
3100 (throw 'found-member-if list) | |
3101 (setq list (cdr list)))) | |
3102 nil)) | |
3103 | |
3104 (defun member-if-not (predicate list) | |
3105 "PREDICATE is applied to the members of LIST. As soon as one of them | |
3106 returns false, that tail of the list if returned. Else NIL." | |
3107 (catch 'found-member-if-not | |
3108 (while (not (endp list)) | |
3109 (if (funcall predicate (car list)) | |
3110 (setq list (cdr list)) | |
3111 (throw 'found-member-if-not list))) | |
3112 nil)) | |
3113 | |
3114 (defun tailp (sublist list) | |
3115 "(tailp SUBLIST LIST) => True if SUBLIST is a sublist of LIST." | |
3116 (catch 'tailp-found | |
3117 (while (not (endp list)) | |
3118 (if (eq sublist list) | |
3119 (throw 'tailp-found t) | |
3120 (setq list (cdr list)))) | |
3121 nil)) | |
3122 | |
3123 ;;; Suggestion of phr%widow.Berkeley.EDU@lilac.berkeley.edu | |
3124 | |
3125 (defmacro declare (&rest decls) | |
3126 "Ignore a Common-Lisp declaration." | |
3127 "declarations are ignored in this implementation") | |
3128 | |
3129 (defun proclaim (&rest decls) | |
3130 "Ignore a Common-Lisp proclamation." | |
3131 "declarations are ignored in this implementation") | |
3132 | |
3133 (defmacro the (type form) | |
3134 "(the TYPE FORM) macroexpands to FORM | |
3135 No checking is even attempted. This is just for compatibility with | |
3136 Common-Lisp codes." | |
3137 form) | |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3138 |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3139 ;;; Due to Aaron Larson (alarson@src.honeywell.com, 26 Jul 91) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3140 (put 'progv 'common-lisp-indent-hook '(4 4 &body)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3141 (defmacro progv (vars vals &rest body) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3142 "progv vars vals &body forms |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3143 bind vars to vals then execute forms. |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3144 If there are more vars than vals, the extra vars are unbound, if |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3145 there are more vals than vars, the extra vals are just ignored." |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3146 (` (progv$runtime (, vars) (, vals) (function (lambda () (,@ body)))))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3147 |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3148 ;;; To do this efficiently, it really needs to be a special form... |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3149 (defun progv$runtime (vars vals body) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3150 (eval (let ((vars-n-vals nil) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3151 (unbind-forms nil)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3152 (do ((r vars (cdr r)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3153 (l vals (cdr l))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3154 ((endp r)) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3155 (push (list (car r) (list 'quote (car l))) vars-n-vals) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3156 (if (null l) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3157 (push (` (makunbound '(, (car r)))) unbind-forms))) |
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3158 (` (let (, vars-n-vals) (,@ unbind-forms) (funcall '(, body))))))) |
188 | 3159 |
662
8a533acedb77
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
584
diff
changeset
|
3160 (provide 'cl) |
584 | 3161 |
1553
6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
Jim Blandy <jimb@redhat.com>
parents:
957
diff
changeset
|
3162 ;;;; end of cl.el |