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