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