1 ;; Common-Lisp extensions for GNU Emacs Lisp.
2 ;; Copyright (C) 1987, 1988, 1989 Free Software Foundation, Inc.
4 ;; This file is part of GNU Emacs.
6 ;; GNU Emacs is distributed in the hope that it will be useful,
7 ;; but WITHOUT ANY WARRANTY. No author or distributor
8 ;; accepts responsibility to anyone for the consequences of using it
9 ;; or for whether it serves any particular purpose or works at all,
10 ;; unless he says so in writing. Refer to the GNU Emacs General Public
11 ;; License for full details.
13 ;; Everyone is granted permission to copy, modify and redistribute
14 ;; GNU Emacs, but only under the conditions described in the
15 ;; GNU Emacs General Public License. A copy of this license is
16 ;; supposed to have been given to you along with GNU Emacs so you
17 ;; can know your rights and responsibilities. It should be in a
18 ;; file named COPYING. Among other things, the copyright notice
19 ;; and this notice must be preserved on all copies.
22 ;;;; These are extensions to Emacs Lisp that provide some form of
23 ;;;; Common Lisp compatibility, beyond what is already built-in
26 ;;;; When developing them, I had the code spread among several files.
27 ;;;; This file 'cl.el' is a concatenation of those original files,
28 ;;;; minus some declarations that became redundant. The marks between
29 ;;;; the original files can be found easily, as they are lines that
30 ;;;; begin with four semicolons (as this does). The names of the
31 ;;;; original parts follow the four semicolons in uppercase, those
32 ;;;; names are GLOBAL, SYMBOLS, LISTS, SEQUENCES, CONDITIONALS,
33 ;;;; ITERATIONS, MULTIPLE VALUES, ARITH, SETF and DEFSTRUCT. If you
34 ;;;; add functions to this file, you might want to put them in a place
35 ;;;; that is compatible with the division above (or invent your own
38 ;;;; To compile this file, make sure you load it first. This is
39 ;;;; because many things are implemented as macros and now that all
40 ;;;; the files are concatenated together one cannot ensure that
41 ;;;; declaration always precedes use.
43 ;;;; Bug reports, suggestions and comments,
44 ;;;; to quiroz@cs.rochester.edu
46 (defvar cl-version "2.0 beta 29 October 1989")
50 ;;;; This file provides utilities and declarations that are global
51 ;;;; to Common Lisp and so might be used by more than one of the
52 ;;;; other libraries. Especially, I intend to keep here some
53 ;;;; utilities that help parsing/destructuring some difficult calls.
56 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
57 ;;;; (quiroz@cs.rochester.edu)
59 ;;; Too many pieces of the rest of this package use psetq. So it is unwise to
60 ;;; use here anything but plain Emacs Lisp! There is a neater recursive form
61 ;;; for the algorithm that deals with the bodies.
63 (defmacro psetq (&rest body)
64 "(psetq {var value }...) => nil
65 Like setq, but all the values are computed before any assignment is made."
66 (let ((length (length body)))
67 (cond ((/= (% length 2) 0)
68 (error "psetq needs an even number of arguments, %d given"
75 (bodyforms (reverse body)))
77 (let* ((value (car bodyforms))
78 (place (cadr bodyforms)))
79 (setq bodyforms (cddr bodyforms))
81 (setq setqs (list 'setq place value))
82 (setq setqs (list 'setq place
89 ;;; pair-with-newsyms takes a list and returns a list of lists of the
90 ;;; form (newsym form), such that a let* can then bind the evaluation
91 ;;; of the forms to the newsyms. The idea is to guarantee correct
92 ;;; order of evaluation of the subforms of a setf. It also returns a
93 ;;; list of the newsyms generated, in the corresponding order.
95 (defun pair-with-newsyms (oldforms)
96 "PAIR-WITH-NEWSYMS OLDFORMS
97 The top-level components of the list oldforms are paired with fresh
98 symbols, the pairings list and the newsyms list are returned."
99 (do ((ptr oldforms (cdr ptr))
102 ((endp ptr) (values (nreverse bindings) (nreverse newsyms)))
103 (let ((newsym (gentemp)))
104 (setq bindings (cons (list newsym (car ptr)) bindings))
105 (setq newsyms (cons newsym newsyms)))))
107 (defun zip-lists (evens odds)
108 "Merge two lists EVENS and ODDS, taking elts from each list alternatingly.
109 EVENS and ODDS are two lists. ZIP-LISTS constructs a new list, whose
110 even numbered elements (0,2,...) come from EVENS and whose odd numbered
111 elements (1,3,...) come from ODDS.
112 The construction stops when the shorter list is exhausted."
113 (do* ((p0 evens (cdr p0))
115 (even (car p0) (car p0))
116 (odd (car p1) (car p1))
118 ((or (endp p0) (endp p1))
121 (cons odd (cons even result)))))
123 (defun unzip-list (list)
124 "Extract even and odd elements of LIST into two separate lists.
125 The argument LIST is separated in two strands, the even and the odd
126 numbered elements. Numbering starts with 0, so the first element
127 belongs in EVENS. No check is made that there is an even number of
128 elements to start with."
129 (do* ((ptr list (cddr ptr))
130 (this (car ptr) (car ptr))
131 (next (cadr ptr) (cadr ptr))
135 (values (nreverse evens) (nreverse odds)))
136 (setq evens (cons this evens))
137 (setq odds (cons next odds))))
139 (defun reassemble-argslists (argslists)
140 "(reassemble-argslists ARGSLISTS) => a list of lists
141 ARGSLISTS is a list of sequences. Return a list of lists, the first
142 sublist being all the entries coming from ELT 0 of the original
143 sublists, the next those coming from ELT 1 and so on, until the
144 shortest list is exhausted."
145 (let* ((minlen (apply 'min (mapcar 'length argslists)))
147 (dotimes (i minlen (nreverse result))
148 ;; capture all the elements at index i
150 (cons (mapcar (function (lambda (sublist) (elt sublist i)))
155 ;;; Checking that a list of symbols contains no duplicates is a common
156 ;;; task when checking the legality of some macros. The check for 'eq
157 ;;; pairs can be too expensive, as it is quadratic on the length of
158 ;;; the list. I use a 4-pass, linear, counting approach. It surely
159 ;;; loses on small lists (less than 5 elements?), but should win for
160 ;;; larger lists. The fourth pass could be eliminated.
161 ;;; 10 dec 1986. Emacs Lisp has no REMPROP, so I just eliminated the
163 (defun duplicate-symbols-p (list)
164 "Find all symbols appearing more than once in LIST.
165 Return a list of all such duplicates; nil if there are no duplicates."
166 (let ((duplicates '()) ;result built here
167 (propname (gensym)) ;we use a fresh property
170 (unless (and (listp list)
171 (every 'symbolp list))
172 (error "a list of symbols is needed"))
178 (put x propname (1+ (get x propname))))
181 (if (> (get x propname) 1)
182 (setq duplicates (cons x duplicates))))
183 ;; pass 4: unmark. eliminated.
184 ;; (dolist (x list) (remprop x propname))
188 ;;;; end of cl-global.el
191 ;;;; This file provides the gentemp function, which generates fresh
192 ;;;; symbols, plus some other minor Common Lisp symbol tools.
194 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
195 ;;;; (quiroz@cs.rochester.edu)
197 ;;; Keywords. There are no packages in Emacs Lisp, so this is only a
198 ;;; kludge around to let things be "as if" a keyword package was around.
200 (defmacro defkeyword (x &optional docstring)
201 "Make symbol X a keyword (symbol whose value is itself).
202 Optional second arg DOCSTRING is a documentation string for it."
204 (list 'defconst x (list 'quote x) docstring))
206 (error "`%s' is not a symbol" (prin1-to-string x)))))
208 (defun keywordp (sym)
209 "Return t if SYM is a keyword."
210 (if (and (symbolp sym) (char-equal (aref (symbol-name sym) 0) ?\:))
211 ;; looks like one, make sure value is right
215 (defun keyword-of (sym)
216 "Return a keyword that is naturally associated with symbol SYM.
217 If SYM is keyword, the value is SYM.
218 Otherwise it is a keyword whose name is `:' followed by SYM's name."
219 (cond ((keywordp sym)
222 (let ((newsym (intern (concat ":" (symbol-name sym)))))
223 (set newsym newsym)))
225 (error "expected a symbol, not `%s'" (prin1-to-string sym)))))
227 ;;; Temporary symbols.
230 (defvar *gentemp-index* 0
231 "Integer used by `gentemp' to produce new names.")
233 (defvar *gentemp-prefix* "T$$_"
234 "Names generated by `gentemp begin' with this string by default.")
236 (defun gentemp (&optional prefix oblist)
237 "Generate a fresh interned symbol.
238 There are two optional arguments, PREFIX and OBLIST. PREFIX is the string
239 that begins the new name, OBLIST is the obarray used to search for old
240 names. The defaults are just right, YOU SHOULD NEVER NEED THESE ARGUMENTS
243 (setq prefix *gentemp-prefix*))
245 (setq oblist obarray)) ;default for the intern functions
246 (let ((newsymbol nil)
248 (while (not newsymbol)
249 (setq newname (concat prefix *gentemp-index*))
250 (setq *gentemp-index* (+ *gentemp-index* 1))
251 (if (not (intern-soft newname oblist))
252 (setq newsymbol (intern newname oblist))))
255 (defvar *gensym-index* 0
256 "Integer used by `gensym' to produce new names.")
258 (defvar *gensym-prefix* "G$$_"
259 "Names generated by `gensym' begin with this string by default.")
261 (defun gensym (&optional prefix)
262 "Generate a fresh uninterned symbol.
263 Optional arg PREFIX is the string that begins the new name. Most people
264 take just the default, except when debugging needs suggest otherwise."
266 (setq prefix *gensym-prefix*))
267 (let ((newsymbol nil)
269 (while (not newsymbol)
270 (setq newname (concat prefix *gensym-index*))
271 (setq *gensym-index* (+ *gensym-index* 1))
272 (if (not (intern-soft newname))
273 (setq newsymbol (make-symbol newname))))
276 ;;;; end of cl-symbols.el
279 ;;;; This file provides some of the conditional constructs of
280 ;;;; Common Lisp. Total compatibility is again impossible, as the
281 ;;;; 'if' form is different in both languages, so only a good
282 ;;;; approximation is desired.
284 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
285 ;;;; (quiroz@cs.rochester.edu)
288 (put 'case 'lisp-indent-function 1)
289 (put 'ecase 'lisp-indent-function 1)
290 (put 'when 'lisp-indent-function 1)
291 (put 'unless 'lisp-indent-function 1)
294 ;;; These two forms are simplified ifs, with a single branch.
296 (defmacro when (condition &rest body)
297 "(when CONDITION . BODY) => evaluate BODY if CONDITION is true."
298 (list* 'if (list 'not condition) '() body))
300 (defmacro unless (condition &rest body)
301 "(unless CONDITION . BODY) => evaluate BODY if CONDITION is false."
302 (list* 'if condition '() body))
305 ;;; CASE selects among several clauses, based on the value (evaluated)
306 ;;; of a expression and a list of (unevaluated) key values. ECASE is
307 ;;; the same, but signals an error if no clause is activated.
309 (defmacro case (expr &rest cases)
310 "(case EXPR . CASES) => evals EXPR, chooses from CASES on that value.
312 CASES -> list of clauses, non empty
313 CLAUSE -> HEAD . BODY
314 HEAD -> t = catch all, must be last clause
315 -> otherwise = same as t
317 -> atom = activated if (eql EXPR HEAD)
318 -> list of atoms = activated if (memq EXPR HEAD)
319 BODY -> list of forms, implicit PROGN is built around it.
320 EXPR is evaluated only once."
321 (let* ((newsym (gentemp))
322 (clauses (case-clausify cases newsym)))
323 ;; convert case into a cond inside a let
325 (list (list newsym expr))
326 (list* 'cond (nreverse clauses)))))
328 (defmacro ecase (expr &rest cases)
329 "(ecase EXPR . CASES) => like `case', but error if no case fits.
330 `t'-clauses are not allowed."
331 (let* ((newsym (gentemp))
332 (clauses (case-clausify cases newsym)))
333 ;; check that no 't clause is present.
334 ;; case-clausify would put one such at the beginning of clauses
335 (if (eq (caar clauses) t)
336 (error "no clause-head should be `t' or `otherwise' for `ecase'"))
337 ;; insert error-catching clause
340 (list 't (list 'error
341 "ecase on %s = %s failed to take any branch"
343 (list 'prin1-to-string newsym)))
345 ;; generate code as usual
347 (list (list newsym expr))
348 (list* 'cond (nreverse clauses)))))
351 (defun case-clausify (cases newsym)
352 "CASE-CLAUSIFY CASES NEWSYM => clauses for a 'cond'
353 Converts the CASES of a [e]case macro into cond clauses to be
354 evaluated inside a let that binds NEWSYM. Returns the clauses in
356 (do* ((currentpos cases (cdr currentpos))
357 (nextpos (cdr cases) (cdr nextpos))
358 (curclause (car cases) (car currentpos))
360 ((endp currentpos) result)
361 (let ((head (car curclause))
362 (body (cdr curclause)))
363 ;; construct a cond-clause according to the head
365 (error "case clauses cannot have null heads: `%s'"
366 (prin1-to-string curclause)))
368 (eq head 'otherwise))
369 ;; check it is the last clause
370 (if (not (endp nextpos))
371 (error "clause with `t' or `otherwise' head must be last"))
372 ;; accept this clause as a 't' for cond
373 (setq result (cons (cons 't body) result)))
376 (cons (cons (list 'eql newsym (list 'quote head)) body)
380 (cons (cons (list 'memq newsym (list 'quote head)) body)
383 ;; catch-all for this parser
384 (error "don't know how to parse case clause `%s'"
385 (prin1-to-string head)))))))
387 ;;;; end of cl-conditionals.el
390 ;;;; This file provides simple iterative macros (a la Common Lisp)
391 ;;;; constructed on the basis of let, let* and while, which are the
392 ;;;; primitive binding/iteration constructs of Emacs Lisp
394 ;;;; The Common Lisp iterations use to have a block named nil
395 ;;;; wrapped around them, and allow declarations at the beginning
396 ;;;; of their bodies and you can return a value using (return ...).
397 ;;;; Nothing of the sort exists in Emacs Lisp, so I haven't tried
398 ;;;; to imitate these behaviors.
400 ;;;; Other than the above, the semantics of Common Lisp are
401 ;;;; correctly reproduced to the extent this was reasonable.
403 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
404 ;;;; (quiroz@cs.rochester.edu)
406 ;;; some lisp-indentation information
407 (put 'do 'lisp-indent-function 2)
408 (put 'do* 'lisp-indent-function 2)
409 (put 'dolist 'lisp-indent-function 1)
410 (put 'dotimes 'lisp-indent-function 1)
411 (put 'do-symbols 'lisp-indent-function 1)
412 (put 'do-all-symbols 'lisp-indent-function 1)
415 (defmacro do (stepforms endforms &rest body)
416 "(do STEPFORMS ENDFORMS . BODY): Iterate BODY, stepping some local
417 variables. STEPFORMS must be a list of symbols or lists. In the second
418 case, the lists must start with a symbol and contain up to two more forms.
419 In the STEPFORMS, a symbol is the same as a (symbol). The other two forms
420 are the initial value (def. NIL) and the form to step (def. itself).
422 The values used by initialization and stepping are computed in parallel.
423 The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION evaluates
424 to true in any iteration, ENDBODY is evaluated and the last form in it is
427 The BODY (which may be empty) is evaluated at every iteration, with the
428 symbols of the STEPFORMS bound to the initial or stepped values."
430 ;; check the syntax of the macro
431 (and (check-do-stepforms stepforms)
432 (check-do-endforms endforms))
433 ;; construct emacs-lisp equivalent
434 (let ((initlist (extract-do-inits stepforms))
435 (steplist (extract-do-steps stepforms))
436 (endcond (car endforms))
437 (endbody (cdr endforms)))
438 (cons 'let (cons initlist
439 (cons (cons 'while (cons (list 'not endcond)
440 (append body steplist)))
441 (append endbody))))))
444 (defmacro do* (stepforms endforms &rest body)
445 "`do*' is to `do' as `let*' is to `let'.
446 STEPFORMS must be a list of symbols or lists. In the second case, the
447 lists must start with a symbol and contain up to two more forms. In the
448 STEPFORMS, a symbol is the same as a (symbol). The other two forms are
449 the initial value (def. NIL) and the form to step (def. itself).
451 Initializations and steppings are done in the sequence they are written.
453 The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION evaluates
454 to true in any iteration, ENDBODY is evaluated and the last form in it is
457 The BODY (which may be empty) is evaluated at every iteration, with
458 the symbols of the STEPFORMS bound to the initial or stepped values."
459 ;; check the syntax of the macro
460 (and (check-do-stepforms stepforms)
461 (check-do-endforms endforms))
462 ;; construct emacs-lisp equivalent
463 (let ((initlist (extract-do-inits stepforms))
464 (steplist (extract-do*-steps stepforms))
465 (endcond (car endforms))
466 (endbody (cdr endforms)))
467 (cons 'let* (cons initlist
468 (cons (cons 'while (cons (list 'not endcond)
469 (append body steplist)))
470 (append endbody))))))
473 ;;; DO and DO* share the syntax checking functions that follow.
475 (defun check-do-stepforms (forms)
476 "True if FORMS is a valid stepforms for the do[*] macro (q.v.)"
478 (error "init/step form for do[*] should be a list, not `%s'"
479 (prin1-to-string forms))
483 (if (not (or (symbolp entry)
485 (symbolp (car entry))
486 (< (length entry) 4))))
487 (error "init/step must be %s, not `%s'"
488 "symbol or (symbol [init [step]])"
489 (prin1-to-string entry)))))
492 (defun check-do-endforms (forms)
493 "True if FORMS is a valid endforms for the do[*] macro (q.v.)"
495 (error "termination form for do macro should be a list, not `%s'"
496 (prin1-to-string forms))))
498 (defun extract-do-inits (forms)
499 "Returns a list of the initializations (for do) in FORMS
500 (a stepforms, see the do macro).
501 FORMS is assumed syntactically valid."
505 (cond ((symbolp entry)
508 (list (car entry) (cadr entry))))))
511 ;;; There used to be a reason to deal with DO differently than with
512 ;;; DO*. The writing of PSETQ has made it largely unnecessary.
514 (defun extract-do-steps (forms)
515 "EXTRACT-DO-STEPS FORMS => an s-expr.
516 FORMS is the stepforms part of a DO macro (q.v.). This function constructs
517 an s-expression that does the stepping at the end of an iteration."
518 (list (cons 'psetq (select-stepping-forms forms))))
520 (defun extract-do*-steps (forms)
521 "EXTRACT-DO*-STEPS FORMS => an s-expr.
522 FORMS is the stepforms part of a DO* macro (q.v.). This function constructs
523 an s-expression that does the stepping at the end of an iteration."
524 (list (cons 'setq (select-stepping-forms forms))))
526 (defun select-stepping-forms (forms)
527 "Separate only the forms that cause stepping."
528 (let ((result '()) ;ends up being (... var form ...)
529 (ptr forms) ;to traverse the forms
530 entry ;to explore each form in turn
532 (while ptr ;(not (endp entry)) might be safer
533 (setq entry (car ptr))
534 (cond ((and (listp entry) (= (length entry) 3))
535 (setq result (append ;append in reverse order!
536 (list (caddr entry) (car entry))
538 (setq ptr (cdr ptr))) ;step in the list of forms
541 ;;; Other iterative constructs
543 (defmacro dolist (stepform &rest body)
544 "(dolist (VAR LIST [RESULTFORM]) . BODY): do BODY for each elt of LIST.
545 The RESULTFORM defaults to nil. The VAR is bound to successive elements
546 of the value of LIST and remains bound (to the nil value) when the
547 RESULTFORM is evaluated."
551 (error "stepform for `dolist' should be (VAR LIST [RESULT]), not `%s'"
552 (prin1-to-string stepform)))
553 ((not (symbolp (car stepform)))
554 (error "first component of stepform should be a symbol, not `%s'"
555 (prin1-to-string (car stepform))))
556 ((> (length stepform) 3)
557 (error "too many components in stepform `%s'"
558 (prin1-to-string stepform))))
560 (let* ((var (car stepform))
561 (listform (cadr stepform))
562 (resultform (caddr stepform)))
566 (cons 'lambda (cons (list var) body)))
569 (list (list var nil))
572 (defmacro dotimes (stepform &rest body)
573 "(dotimes (VAR COUNTFORM [RESULTFORM]) . BODY): Repeat BODY, counting in VAR.
574 The COUNTFORM should return a positive integer. The VAR is bound to
575 successive integers from 0 to COUNTFORM - 1 and the BODY is repeated for
576 each of them. At the end, the RESULTFORM is evaluated and its value
577 returned. During this last evaluation, the VAR is still bound, and its
578 value is the number of times the iteration occurred. An omitted RESULTFORM
583 (error "stepform for `dotimes' should be (VAR COUNT [RESULT]), not `%s'"
584 (prin1-to-string stepform)))
585 ((not (symbolp (car stepform)))
586 (error "first component of stepform should be a symbol, not `%s'"
587 (prin1-to-string (car stepform))))
588 ((> (length stepform) 3)
589 (error "too many components in stepform `%s'"
590 (prin1-to-string stepform))))
592 (let* ((var (car stepform))
593 (countform (cadr stepform))
594 (resultform (caddr stepform))
597 'let* (list (list newsym countform))
600 (list (list var 0 (list '+ var 1)))
601 (list (list '>= var newsym) resultform)
604 (defmacro do-symbols (stepform &rest body)
605 "(do_symbols (VAR [OBARRAY [RESULTFORM]]) . BODY)
606 The VAR is bound to each of the symbols in OBARRAY (def. obarray) and
607 the BODY is repeatedly performed for each of those bindings. At the
608 end, RESULTFORM (def. nil) is evaluated and its value returned.
609 During this last evaluation, the VAR is still bound and its value is nil.
610 See also the function `mapatoms'."
614 (error "stepform for `do-symbols' should be (VAR OBARRAY [RESULT]), not `%s'"
615 (prin1-to-string stepform)))
616 ((not (symbolp (car stepform)))
617 (error "first component of stepform should be a symbol, not `%s'"
618 (prin1-to-string (car stepform))))
619 ((> (length stepform) 3)
620 (error "too many components in stepform `%s'"
621 (prin1-to-string stepform))))
623 (let* ((var (car stepform))
624 (oblist (cadr stepform))
625 (resultform (caddr stepform)))
629 (cons 'lambda (cons (list var) body)))
632 (list (list var nil))
636 (defmacro do-all-symbols (stepform &rest body)
637 "(do-all-symbols (VAR [RESULTFORM]) . BODY)
638 Is the same as (do-symbols (VAR obarray RESULTFORM) . BODY)."
641 (list (car stepform) 'obarray (cadr stepform))
644 (defmacro loop (&rest body)
645 "(loop . BODY) repeats BODY indefinitely and does not return.
646 Normally BODY uses `throw' or `signal' to cause an exit.
647 The forms in BODY should be lists, as non-lists are reserved for new features."
648 ;; check that the body doesn't have atomic forms
650 (error "body of `loop' should be a list of lists or nil")
651 ;; ok, it is a list, check for atomic components
653 (function (lambda (component)
654 (if (nlistp component)
655 (error "components of `loop' should be lists"))))
657 ;; build the infinite loop
658 (cons 'while (cons 't body))))
660 ;;;; end of cl-iterations.el
663 ;;;; This file provides some of the lists machinery of Common-Lisp
664 ;;;; in a way compatible with Emacs Lisp. Especially, see the the
665 ;;;; typical c[ad]*r functions.
667 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
668 ;;;; (quiroz@cs.rochester.edu)
670 (defvar *cl-valid-named-list-accessors*
671 '(first rest second third fourth fifth sixth seventh eighth ninth tenth))
672 (defvar *cl-valid-nth-offsets*
683 (defun byte-compile-named-list-accessors (form)
684 "Generate code for (<accessor> FORM), where <accessor> is one of the named
685 list accessors: first, second, ..., tenth, rest."
686 (let* ((fun (car form))
688 (valid *cl-valid-named-list-accessors*)
689 (offsets *cl-valid-nth-offsets*))
690 (if (or (null (cdr form)) (cddr form))
691 (error "%s needs exactly one argument, seen `%s'"
692 fun (prin1-to-string form)))
693 (if (not (memq fun valid))
694 (error "`%s' not in {first, ..., tenth, rest}" fun))
695 (cond ((eq fun 'first)
696 (byte-compile-form arg)
697 (setq byte-compile-depth (1- byte-compile-depth))
698 (byte-compile-out byte-car 0))
700 (byte-compile-form arg)
701 (setq byte-compile-depth (1- byte-compile-depth))
702 (byte-compile-out byte-cdr 0))
703 (t ;one of the others
704 (byte-compile-constant (cdr (assoc fun offsets)))
705 (byte-compile-form arg)
706 (setq byte-compile-depth (1- byte-compile-depth))
707 (byte-compile-out byte-nth 0)
710 ;;; Synonyms for list functions
714 (put 'first 'byte-compile 'byte-compile-named-list-accessors)
717 "Return the second element of the list LIST."
719 (put 'second 'byte-compile 'byte-compile-named-list-accessors)
722 "Return the third element of the list LIST."
724 (put 'third 'byte-compile 'byte-compile-named-list-accessors)
727 "Return the fourth element of the list LIST."
729 (put 'fourth 'byte-compile 'byte-compile-named-list-accessors)
732 "Return the fifth element of the list LIST."
734 (put 'fifth 'byte-compile 'byte-compile-named-list-accessors)
737 "Return the sixth element of the list LIST."
739 (put 'sixth 'byte-compile 'byte-compile-named-list-accessors)
742 "Return the seventh element of the list LIST."
744 (put 'seventh 'byte-compile 'byte-compile-named-list-accessors)
747 "Return the eighth element of the list LIST."
749 (put 'eighth 'byte-compile 'byte-compile-named-list-accessors)
752 "Return the ninth element of the list LIST."
754 (put 'ninth 'byte-compile 'byte-compile-named-list-accessors)
757 "Return the tenth element of the list LIST."
759 (put 'tenth 'byte-compile 'byte-compile-named-list-accessors)
764 (put 'rest 'byte-compile 'byte-compile-named-list-accessors)
767 "t if X is nil, nil if X is a cons; error otherwise."
770 (error "endp received a non-cons, non-null argument `%s'"
771 (prin1-to-string x))))
774 "Returns the last link in the list LIST."
776 (error "arg to `last' must be a list"))
777 (do ((current-cons x (cdr current-cons))
778 (next-cons (cdr x) (cdr next-cons)))
779 ((endp next-cons) current-cons)))
781 (defun list-length (x) ;taken from CLtL sect. 15.2
782 "Returns the length of a non-circular list, or `nil' for a circular one."
784 (fast x (cddr fast)) ;fast pointer, leaps by 2
785 (slow x (cdr slow)) ;slow pointer, leaps by 1
786 (ready nil)) ;indicates termination
789 (setq ready t)) ;return n
792 (setq ready t)) ;return n+1
793 ((and (eq fast slow) (> n 0))
795 (setq ready t)) ;return nil
797 (setq n (+ n 2)))))) ;just advance counter
799 (defun butlast (list &optional n)
800 "Return a new list like LIST but sans the last N elements.
801 N defaults to 1. If the list doesn't have N elements, nil is returned."
802 (if (null n) (setq n 1))
803 (reverse (nthcdr n (reverse list))))
805 (defun list* (arg &rest others)
806 "Return a new list containing the first arguments consed onto the last arg.
807 Thus, (list* 1 2 3 '(a b)) returns (1 2 3 a b)."
810 (let* ((allargs (cons arg others))
811 (front (butlast allargs))
812 (back (last allargs)))
813 (rplacd (last front) (car back))
816 (defun adjoin (item list)
817 "Return a list which contains ITEM but is otherwise like LIST.
818 If ITEM occurs in LIST, the value is LIST. Otherwise it is (cons ITEM LIST).
819 When comparing ITEM against elements, `eql' is used."
824 (defun ldiff (list sublist)
825 "Return a new list like LIST but sans SUBLIST.
826 SUBLIST must be one of the links in LIST; otherwise the value is LIST itself."
828 (curcons list (cdr curcons)))
829 ((or (endp curcons) (eq curcons sublist))
831 (setq result (cons (car curcons) result))))
833 ;;; The popular c[ad]*r functions and other list accessors.
835 ;;; To implement this efficiently, a new byte compile handler is used to
836 ;;; generate the minimal code, saving one function call.
838 (defun byte-compile-ca*d*r (form)
839 "Generate code for a (c[ad]+r argument). This realizes the various
840 combinations of car and cdr whose names are supported in this implementation.
841 To use this functionality for a given function,just give its name a
842 'byte-compile property of 'byte-compile-ca*d*r"
843 (let* ((fun (car form))
845 (seq (mapcar (function (lambda (letter)
847 'byte-car 'byte-cdr)))
848 (cdr (nreverse (cdr (append (symbol-name fun) nil)))))))
849 ;; SEQ is a list of byte-car and byte-cdr in the correct order.
851 (error "internal: `%s' cannot be compiled by byte-compile-ca*d*r"
852 (prin1-to-string form)))
853 (if (or (null (cdr form)) (cddr form))
854 (error "%s needs exactly one argument, seen `%s'"
855 fun (prin1-to-string form)))
856 (byte-compile-form arg)
857 (setq byte-compile-depth (1- byte-compile-depth))
858 ;; the rest of this code doesn't change the stack depth!
860 (byte-compile-out (car seq) 0)
861 (setq seq (cdr seq)))))
864 "Return the car of the car of X."
866 (put 'caar 'byte-compile 'byte-compile-ca*d*r)
869 "Return the car of the cdr of X."
871 (put 'cadr 'byte-compile 'byte-compile-ca*d*r)
874 "Return the cdr of the car of X."
876 (put 'cdar 'byte-compile 'byte-compile-ca*d*r)
879 "Return the cdr of the cdr of X."
881 (put 'cddr 'byte-compile 'byte-compile-ca*d*r)
884 "Return the car of the car of the car of X."
886 (put 'caaar 'byte-compile 'byte-compile-ca*d*r)
889 "Return the car of the car of the cdr of X."
891 (put 'caadr 'byte-compile 'byte-compile-ca*d*r)
894 "Return the car of the cdr of the car of X."
896 (put 'cadar 'byte-compile 'byte-compile-ca*d*r)
899 "Return the cdr of the car of the car of X."
901 (put 'cdaar 'byte-compile 'byte-compile-ca*d*r)
904 "Return the car of the cdr of the cdr of X."
906 (put 'caddr 'byte-compile 'byte-compile-ca*d*r)
909 "Return the cdr of the car of the cdr of X."
911 (put 'cdadr 'byte-compile 'byte-compile-ca*d*r)
914 "Return the cdr of the cdr of the car of X."
916 (put 'cddar 'byte-compile 'byte-compile-ca*d*r)
919 "Return the cdr of the cdr of the cdr of X."
921 (put 'cdddr 'byte-compile 'byte-compile-ca*d*r)
924 "Return the car of the car of the car of the car of X."
925 (car (car (car (car X)))))
926 (put 'caaaar 'byte-compile 'byte-compile-ca*d*r)
929 "Return the car of the car of the car of the cdr of X."
930 (car (car (car (cdr X)))))
931 (put 'caaadr 'byte-compile 'byte-compile-ca*d*r)
934 "Return the car of the car of the cdr of the car of X."
935 (car (car (cdr (car X)))))
936 (put 'caadar 'byte-compile 'byte-compile-ca*d*r)
939 "Return the car of the cdr of the car of the car of X."
940 (car (cdr (car (car X)))))
941 (put 'cadaar 'byte-compile 'byte-compile-ca*d*r)
944 "Return the cdr of the car of the car of the car of X."
945 (cdr (car (car (car X)))))
946 (put 'cdaaar 'byte-compile 'byte-compile-ca*d*r)
949 "Return the car of the car of the cdr of the cdr of X."
950 (car (car (cdr (cdr X)))))
951 (put 'caaddr 'byte-compile 'byte-compile-ca*d*r)
954 "Return the car of the cdr of the car of the cdr of X."
955 (car (cdr (car (cdr X)))))
956 (put 'cadadr 'byte-compile 'byte-compile-ca*d*r)
959 "Return the cdr of the car of the car of the cdr of X."
960 (cdr (car (car (cdr X)))))
961 (put 'cdaadr 'byte-compile 'byte-compile-ca*d*r)
964 "Return the car of the cdr of the cdr of the car of X."
965 (car (cdr (cdr (car X)))))
966 (put 'caddar 'byte-compile 'byte-compile-ca*d*r)
969 "Return the cdr of the car of the cdr of the car of X."
970 (cdr (car (cdr (car X)))))
971 (put 'cdadar 'byte-compile 'byte-compile-ca*d*r)
974 "Return the cdr of the cdr of the car of the car of X."
975 (cdr (cdr (car (car X)))))
976 (put 'cddaar 'byte-compile 'byte-compile-ca*d*r)
979 "Return the car of the cdr of the cdr of the cdr of X."
980 (car (cdr (cdr (cdr X)))))
981 (put 'cadddr 'byte-compile 'byte-compile-ca*d*r)
984 "Return the cdr of the cdr of the car of the cdr of X."
985 (cdr (cdr (car (cdr X)))))
986 (put 'cddadr 'byte-compile 'byte-compile-ca*d*r)
989 "Return the cdr of the car of the cdr of the cdr of X."
990 (cdr (car (cdr (cdr X)))))
991 (put 'cdaddr 'byte-compile 'byte-compile-ca*d*r)
994 "Return the cdr of the cdr of the cdr of the car of X."
995 (cdr (cdr (cdr (car X)))))
996 (put 'cdddar 'byte-compile 'byte-compile-ca*d*r)
999 "Return the cdr of the cdr of the cdr of the cdr of X."
1000 (cdr (cdr (cdr (cdr X)))))
1001 (put 'cddddr 'byte-compile 'byte-compile-ca*d*r)
1003 ;;; some inverses of the accessors are needed for setf purposes
1005 (defun setnth (n list newval)
1006 "Set (nth N LIST) to NEWVAL. Returns NEWVAL."
1007 (rplaca (nthcdr n list) newval))
1009 (defun setnthcdr (n list newval)
1010 "(setnthcdr N LIST NEWVAL) => NEWVAL
1011 As a side effect, sets the Nth cdr of LIST to NEWVAL."
1013 (error "N must be 0 or greater, not %d" n))
1015 (rplaca list (car newval))
1016 (rplacd list (cdr newval))
1019 (rplacd (nthcdr (- n 1) list) newval))))
1021 ;;; A-lists machinery
1023 (defun acons (key item alist)
1024 "Return a new alist with KEY paired with ITEM; otherwise like ALIST.
1025 Does not copy ALIST."
1026 (cons (cons key item) alist))
1028 (defun pairlis (keys data &optional alist)
1029 "Return a new alist with each elt of KEYS paired with an elt of DATA;
1030 optional 3rd arg ALIST is nconc'd at the end. KEYS and DATA must
1031 have the same length."
1032 (unless (= (length keys) (length data))
1033 (error "keys and data should be the same length"))
1034 (do* ;;collect keys and data in front of alist
1035 ((kptr keys (cdr kptr)) ;traverses the keys
1036 (dptr data (cdr dptr)) ;traverses the data
1037 (key (car kptr) (car kptr)) ;current key
1038 (item (car dptr) (car dptr)) ;current data item
1040 ((endp kptr) result)
1041 (setq result (acons key item result))))
1045 ;;;; Emacs Lisp provides many of the 'sequences' functionality of
1046 ;;;; Common Lisp. This file provides a few things that were left out.
1050 (defkeyword :test "Used to designate positive (selection) tests.")
1051 (defkeyword :test-not "Used to designate negative (rejection) tests.")
1052 (defkeyword :key "Used to designate component extractions.")
1053 (defkeyword :predicate "Used to define matching of sequence components.")
1054 (defkeyword :start "Inclusive low index in sequence")
1055 (defkeyword :end "Exclusive high index in sequence")
1056 (defkeyword :start1 "Inclusive low index in first of two sequences.")
1057 (defkeyword :start2 "Inclusive low index in second of two sequences.")
1058 (defkeyword :end1 "Exclusive high index in first of two sequences.")
1059 (defkeyword :end2 "Exclusive high index in second of two sequences.")
1060 (defkeyword :count "Number of elements to affect.")
1061 (defkeyword :from-end "T when counting backwards.")
1063 (defun some (pred seq &rest moreseqs)
1064 "Test PREDICATE on each element of SEQUENCE; is it ever non-nil?
1065 Extra args are additional sequences; PREDICATE gets one arg from each
1066 sequence and we advance down all the sequences together in lock-step.
1067 A sequence means either a list or a vector."
1068 (let ((args (reassemble-argslists (list* seq moreseqs))))
1069 (do* ((ready nil) ;flag: return when t
1070 (result nil) ;resulting value
1071 (applyval nil) ;result of applying pred once
1073 (cdr remaining)) ;remaining argument sets
1074 (current (car remaining) ;current argument set
1076 ((or ready (endp remaining)) result)
1077 (setq applyval (apply pred current))
1080 (setq result applyval)))))
1082 (defun every (pred seq &rest moreseqs)
1083 "Test PREDICATE on each element of SEQUENCE; is it always non-nil?
1084 Extra args are additional sequences; PREDICATE gets one arg from each
1085 sequence and we advance down all the sequences together in lock-step.
1086 A sequence means either a list or a vector."
1087 (let ((args (reassemble-argslists (list* seq moreseqs))))
1088 (do* ((ready nil) ;flag: return when t
1089 (result t) ;resulting value
1090 (applyval nil) ;result of applying pred once
1092 (cdr remaining)) ;remaining argument sets
1093 (current (car remaining) ;current argument set
1095 ((or ready (endp remaining)) result)
1096 (setq applyval (apply pred current))
1099 (setq result nil)))))
1101 (defun notany (pred seq &rest moreseqs)
1102 "Test PREDICATE on each element of SEQUENCE; is it always nil?
1103 Extra args are additional sequences; PREDICATE gets one arg from each
1104 sequence and we advance down all the sequences together in lock-step.
1105 A sequence means either a list or a vector."
1106 (let ((args (reassemble-argslists (list* seq moreseqs))))
1107 (do* ((ready nil) ;flag: return when t
1108 (result t) ;resulting value
1109 (applyval nil) ;result of applying pred once
1111 (cdr remaining)) ;remaining argument sets
1112 (current (car remaining) ;current argument set
1114 ((or ready (endp remaining)) result)
1115 (setq applyval (apply pred current))
1118 (setq result nil)))))
1120 (defun notevery (pred seq &rest moreseqs)
1121 "Test PREDICATE on each element of SEQUENCE; is it sometimes nil?
1122 Extra args are additional sequences; PREDICATE gets one arg from each
1123 sequence and we advance down all the sequences together in lock-step.
1124 A sequence means either a list or a vector."
1125 (let ((args (reassemble-argslists (list* seq moreseqs))))
1126 (do* ((ready nil) ;flag: return when t
1127 (result nil) ;resulting value
1128 (applyval nil) ;result of applying pred once
1130 (cdr remaining)) ;remaining argument sets
1131 (current (car remaining) ;current argument set
1133 ((or ready (endp remaining)) result)
1134 (setq applyval (apply pred current))
1139 ;;; More sequence functions that don't need keyword arguments
1141 (defun concatenate (type &rest sequences)
1142 "(concatenate TYPE &rest SEQUENCES) => a sequence
1143 The sequence returned is of type TYPE (must be 'list, 'string, or 'vector) and
1144 contains the concatenation of the elements of all the arguments, in the order
1146 (let ((sequences (append sequences '(()))))
1149 (apply (function append) sequences))
1151 (apply (function concat) sequences))
1153 (apply (function vector) (apply (function append) sequences)))
1155 (error "type for concatenate `%s' not 'list, 'string or 'vector"
1156 (prin1-to-string type))))))
1158 (defun map (type function &rest sequences)
1159 "(map TYPE FUNCTION &rest SEQUENCES) => a sequence
1160 The FUNCTION is called on each set of elements from the SEQUENCES \(stopping
1161 when the shortest sequence is terminated\) and the results are possibly
1162 returned in a sequence of type TYPE \(one of 'list, 'vector, 'string, or nil\)
1163 giving NIL for TYPE gets rid of the values."
1164 (if (not (memq type (list 'list 'string 'vector nil)))
1165 (error "type for map `%s' not 'list, 'string, 'vector or nil"
1166 (prin1-to-string type)))
1167 (let ((argslists (reassemble-argslists sequences))
1170 (while argslists ;don't bother accumulating
1171 (apply function (car argslists))
1172 (setq argslists (cdr argslists)))
1173 (setq results (mapcar (function (lambda (args) (apply function args)))
1179 (funcall (function concat) results))
1181 (apply (function vector) results))))))
1183 ;;; an inverse of elt is needed for setf purposes
1185 (defun setelt (seq n newval)
1186 "In SEQUENCE, set the Nth element to NEWVAL. Returns NEWVAL.
1187 A sequence means either a list or a vector."
1188 (let ((l (length seq)))
1189 (if (or (< n 0) (>= n l))
1190 (error "N(%d) should be between 0 and %d" n l)
1191 ;; only two cases need be considered valid, as strings are arrays
1193 (setnth n seq newval))
1195 (aset seq n newval))
1197 (error "SEQ should be a sequence, not `%s'"
1198 (prin1-to-string seq)))))))
1200 ;;; Testing with keyword arguments.
1202 ;;; Many of the sequence functions use keywords to denote some stylized
1203 ;;; form of selecting entries in a sequence. The involved arguments
1204 ;;; are collected with a &rest marker (as Emacs Lisp doesn't have a &key
1205 ;;; marker), then they are passed to build-klist, who
1206 ;;; constructs an association list. That association list is used to
1207 ;;; test for satisfaction and matching.
1209 ;;; DON'T USE MEMBER, NOR ANY FUNCTION THAT COULD TAKE KEYWORDS HERE!!!
1211 (defun build-klist (argslist acceptable &optional allow-other-keys)
1212 "Decode a keyword argument list ARGSLIST for keywords in ACCEPTABLE.
1213 ARGSLIST is a list, presumably the &rest argument of a call, whose
1214 even numbered elements must be keywords.
1215 ACCEPTABLE is a list of keywords, the only ones that are truly acceptable.
1216 The result is an alist containing the arguments named by the keywords
1217 in ACCEPTABLE, or an error is signalled, if something failed.
1218 If the third argument (an optional) is non-nil, other keys are acceptable."
1219 ;; check legality of the arguments, then destructure them
1220 (unless (and (listp argslist)
1221 (evenp (length argslist)))
1222 (error "build-klist: odd number of keyword-args"))
1223 (unless (and (listp acceptable)
1224 (every 'keywordp acceptable))
1225 (error "build-klist: second arg should be a list of keywords"))
1226 (multiple-value-bind
1228 (unzip-list argslist)
1229 (unless (every 'keywordp keywords)
1230 (error "build-klist: expected keywords, found `%s'"
1231 (prin1-to-string keywords)))
1232 (unless (or allow-other-keys
1233 (every (function (lambda (keyword)
1234 (memq keyword acceptable)))
1236 (error "bad keyword[s]: %s not in %s"
1237 (prin1-to-string (mapcan (function (lambda (keyword)
1238 (if (memq keyword acceptable)
1242 (prin1-to-string acceptable)))
1243 (do* ;;pick up the pieces
1244 ((auxlist ;auxiliary a-list, may
1245 (pairlis keywords forms)) ;contain repetitions and junk
1246 (ptr acceptable (cdr ptr)) ;pointer in acceptable
1247 (this (car ptr) (car ptr)) ;current acceptable keyword
1248 (auxval nil) ;used to move values around
1249 (alist '())) ;used to build the result
1251 ;; if THIS appears in auxlist, use its value
1252 (when (setq auxval (assq this auxlist))
1253 (setq alist (cons auxval alist))))))
1256 (defun extract-from-klist (klist key &optional default)
1257 "(extract-from-klist KLIST KEY [DEFAULT]) => value of KEY or DEFAULT
1258 Extract value associated with KEY in KLIST (return DEFAULT if nil)."
1259 (let ((retrieved (cdr (assq key klist))))
1260 (or retrieved default)))
1262 (defun keyword-argument-supplied-p (klist key)
1263 "(keyword-argument-supplied-p KLIST KEY) => nil or something
1264 NIL if KEY (a keyword) does not appear in the KLIST."
1267 (defun add-to-klist (key item klist)
1268 "(ADD-TO-KLIST KEY ITEM KLIST) => new KLIST
1269 Add association (KEY . ITEM) to KLIST."
1270 (setq klist (acons key item klist)))
1272 (defun elt-satisfies-test-p (item elt klist)
1273 "(elt-satisfies-test-p ITEM ELT KLIST) => t or nil
1274 KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
1275 True if the given ITEM and ELT satisfy the test."
1276 (let ((test (extract-from-klist klist :test))
1277 (test-not (extract-from-klist klist :test-not))
1278 (keyfn (extract-from-klist klist :key 'identity)))
1280 (funcall test item (funcall keyfn elt)))
1282 (not (funcall test-not item (funcall keyfn elt))))
1283 (t ;should never happen
1284 (error "neither :test nor :test-not in `%s'"
1285 (prin1-to-string klist))))))
1287 (defun elt-satisfies-if-p (item klist)
1288 "(elt-satisfies-if-p ITEM KLIST) => t or nil
1289 True if an -if style function was called and ITEM satisfies the
1290 predicate under :predicate in KLIST."
1291 (let ((predicate (extract-from-klist klist :predicate))
1292 (keyfn (extract-from-klist klist :key 'identity)))
1293 (funcall predicate item (funcall keyfn elt))))
1295 (defun elt-satisfies-if-not-p (item klist)
1296 "(elt-satisfies-if-not-p ITEM KLIST) => t or nil
1297 KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
1298 True if an -if-not style function was called and ITEM does not satisfy
1299 the predicate under :predicate in KLIST."
1300 (let ((predicate (extract-from-klist klist :predicate))
1301 (keyfn (extract-from-klist klist :key 'identity)))
1302 (not (funcall predicate item (funcall keyfn elt)))))
1304 (defun elts-match-under-klist-p (e1 e2 klist)
1305 "(elts-match-under-klist-p E1 E2 KLIST) => t or nil
1306 KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
1307 True if elements E1 and E2 match under the tests encoded in KLIST."
1308 (let ((test (extract-from-klist klist :test))
1309 (test-not (extract-from-klist klist :test-not))
1310 (keyfn (extract-from-klist klist :key 'identity)))
1311 (if (and test test-not)
1312 (error "both :test and :test-not in `%s'"
1313 (prin1-to-string klist)))
1315 (funcall test (funcall keyfn e1) (funcall keyfn e2)))
1317 (not (funcall test-not (funcall keyfn e1) (funcall keyfn e2))))
1318 (t ;should never happen
1319 (error "neither :test nor :test-not in `%s'"
1320 (prin1-to-string klist))))))
1322 ;;; This macro simplifies using keyword args. It is less clumsy than using
1323 ;;; the primitives build-klist, etc... For instance, member could be written
1326 ;;; (defun member (item list &rest kargs)
1327 ;;; (with-keyword-args kargs (test test-not (key 'identity))
1330 ;;; Suggested by Robert Potter (potter@cs.rochester.edu, 15 Nov 1989)
1332 (defmacro with-keyword-args (keyargslist vardefs &rest body)
1333 "(WITH-KEYWORD-ARGS KEYARGSLIST VARDEFS . BODY)
1334 KEYARGSLIST can be either a symbol or a list of one or two symbols.
1335 In the second case, the second symbol is either T or NIL, indicating whether
1336 keywords other than the mentioned ones are tolerable.
1338 VARDEFS is a list. Each entry is either a VAR (symbol) or matches
1339 \(VAR [DEFAULT [KEYWORD]]). Just giving VAR is the same as giving
1342 The BODY is executed in an environment where each VAR (a symbol) is bound to
1343 the value present in the KEYARGSLIST provided, or to the DEFAULT. The value
1344 is searched by using the keyword form of VAR (i.e., :VAR) or the optional
1345 keyword if provided.
1347 Notice that this macro doesn't distinguish between a default value given
1348 explicitly by the user and one provided by default. See also the more
1349 primitive functions build-klist, add-to-klist, extract-from-klist,
1350 keyword-argument-supplied-p, elt-satisfies-test-p, elt-satisfies-if-p,
1351 elt-satisfies-if-not-p, elts-match-under-klist-p. They provide more complete,
1352 if clumsier, control over this feature."
1353 (let (allow-other-keys)
1354 (if (listp keyargslist)
1355 (if (> (length keyargslist) 2)
1357 "`%s' should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)"
1358 (prin1-to-string keyargslist))
1359 (setq allow-other-keys (cadr keyargslist)
1360 keyargslist (car keyargslist))
1362 (symbolp keyargslist)
1363 (memq allow-other-keys '(t nil))))
1365 "first subform should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)"
1367 (if (symbolp keyargslist)
1368 (setq allow-other-keys nil)
1370 "first subform should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)")))
1371 (let (vars defaults keywords forms
1372 (klistname (gensym "KLIST_")))
1373 (mapcar (function (lambda (entry)
1374 (if (symbolp entry) ;defaulty case
1375 (setq entry (list entry nil (keyword-of entry))))
1376 (let* ((l (length entry))
1380 (if (or (< l 1) (> l 3))
1382 "`%s' must match (VAR [DEFAULT [KEYWORD]])"
1383 (prin1-to-string entry)))
1384 (if (or (null v) (not (symbolp v)))
1386 "bad variable `%s': must be non-null symbol"
1387 (prin1-to-string v)))
1388 (setq vars (cons v vars))
1389 (setq defaults (cons d defaults))
1391 (setq k (keyword-of v)))
1394 (not (keywordp k))))
1396 "bad keyword `%s'" (prin1-to-string k)))
1397 (setq keywords (cons k keywords))
1398 (setq forms (cons (list v (list 'extract-from-klist
1405 (list 'let* (nconc (list (list klistname
1406 (list 'build-klist keyargslist
1407 (list 'quote keywords)
1411 (put 'with-keyword-args 'lisp-indent-function 1)
1415 ;;; It is here mostly as an example of how to use KLISTs.
1417 ;;; First of all, you need to declare the keywords (done elsewhere in this
1419 ;;; (defkeyword :from-end "syntax of sequence functions")
1420 ;;; (defkeyword :start "syntax of sequence functions")
1423 ;;; Then, you capture all the possible keyword arguments with a &rest
1424 ;;; argument. You can pass that list downward again, of course, but
1425 ;;; internally you need to parse it into a KLIST (an alist, really). One uses
1426 ;;; (build-klist REST-ARGS ACCEPTABLE-KEYWORDS [ALLOW-OTHER]). You can then
1427 ;;; test for presence by using (keyword-argument-supplied-p KLIST KEY) and
1428 ;;; extract a value with (extract-from-klist KLIST KEY [DEFAULT]).
1430 (defun reduce (function sequence &rest kargs)
1431 "Apply FUNCTION (a function of two arguments) to succesive pairs of elements
1432 from SEQUENCE. Some keyword arguments are valid after FUNCTION and SEQUENCE:
1433 :from-end If non-nil, process the values backwards
1434 :initial-value If given, prefix it to the SEQUENCE. Suffix, if :from-end
1435 :start Restrict reduction to the subsequence from this index
1436 :end Restrict reduction to the subsequence BEFORE this index.
1437 If the sequence is empty and no :initial-value is given, the FUNCTION is
1438 called on zero (not two) arguments. Otherwise, if there is exactly one
1439 element in the combination of SEQUENCE and the initial value, that element is
1441 (let* ((klist (build-klist kargs '(:from-end :start :end :initial-value)))
1442 (length (length sequence))
1443 (from-end (extract-from-klist klist :from-end))
1444 (initial-value-given (keyword-argument-supplied-p
1445 klist :initial-value))
1446 (start (extract-from-klist kargs :start 0))
1447 (end (extract-from-klist kargs :end length)))
1448 (setq sequence (cl$subseq-as-list sequence start end))
1450 (setq sequence (reverse sequence)))
1451 (if initial-value-given
1452 (setq sequence (cons (extract-from-klist klist :initial-value)
1455 (funcall function) ;only use of 0 arguments
1456 (let* ((result (car sequence))
1457 (sequence (cdr sequence)))
1459 (setq result (if from-end
1460 (funcall function (car sequence) result)
1461 (funcall function result (car sequence)))
1462 sequence (cdr sequence)))
1465 (defun cl$subseq-as-list (sequence start end)
1466 "(cl$subseq-as-list SEQUENCE START END) => a list"
1467 (let ((list (append sequence nil))
1468 (length (length sequence))
1471 (error "start should be >= 0, not %d" start))
1473 (error "end should be <= %d, not %d" length end))
1474 (if (and (zerop start) (= end length))
1477 (vector (apply 'vector list)))
1479 (setq result (cons (elt vector i) result))
1481 (nreverse result)))))
1483 ;;;; end of cl-sequences.el
1485 ;;;; Some functions with keyword arguments
1487 ;;;; Both list and sequence functions are considered here together. This
1488 ;;;; doesn't fit any more with the original split of functions in files.
1490 (defun member (item list &rest kargs)
1491 "Look for ITEM in LIST; return first tail of LIST the car of whose first
1492 cons cell tests the same as ITEM. Admits arguments :key, :test, and :test-not."
1493 (if (null kargs) ;treat this fast for efficiency
1495 (let* ((klist (build-klist kargs '(:test :test-not :key)))
1496 (test (extract-from-klist klist :test))
1497 (testnot (extract-from-klist klist :test-not))
1498 (key (extract-from-klist klist :key 'identity)))
1499 ;; another workaround allegledly for speed
1500 (if (and (or (eq test 'eq) (eq test 'eql)
1501 (eq test (symbol-function 'eq))
1502 (eq test (symbol-function 'eql)))
1504 (or (eq key 'identity) ;either by default or so given
1505 (eq key (function identity)) ;could this happen?
1506 (eq key (symbol-function 'identity)) ;sheer paranoia
1509 (if (and test testnot)
1510 (error ":test and :test-not both specified for member"))
1511 (if (not (or test testnot))
1513 ;; final hack: remove the indirection through the function names
1515 (if (symbolp testnot)
1516 (setq testnot (symbol-function testnot)))
1518 (setq test (symbol-function test))))
1520 (setq key (symbol-function key)))
1526 (while (not (or done (endp ptr)))
1527 (cond ((not (funcall testnot item (funcall key (car ptr))))
1530 (setq ptr (cdr ptr)))
1531 (while (not (or done (endp ptr)))
1532 (cond ((funcall test item (funcall key (car ptr)))
1535 (setq ptr (cdr ptr))))
1538 ;;;; MULTIPLE VALUES
1539 ;;;; This package approximates the behavior of the multiple-values
1540 ;;;; forms of Common Lisp.
1542 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
1543 ;;;; (quiroz@cs.rochester.edu)
1545 ;;; Lisp indentation information
1546 (put 'multiple-value-bind 'lisp-indent-function 2)
1547 (put 'multiple-value-setq 'lisp-indent-function 2)
1548 (put 'multiple-value-list 'lisp-indent-function nil)
1549 (put 'multiple-value-call 'lisp-indent-function 1)
1550 (put 'multiple-value-prog1 'lisp-indent-function 1)
1552 ;;; Global state of the package is kept here
1553 (defvar *mvalues-values* nil
1554 "Most recently returned multiple-values")
1555 (defvar *mvalues-count* nil
1556 "Count of multiple-values returned, or nil if the mechanism was not used")
1558 ;;; values is the standard multiple-value-return form. Must be the
1559 ;;; last thing evaluated inside a function. If the caller is not
1560 ;;; expecting multiple values, only the first one is passed. (values)
1561 ;;; is the same as no-values returned (unaware callers see nil). The
1562 ;;; alternative (values-list <list>) is just a convenient shorthand
1563 ;;; and complements multiple-value-list.
1565 (defun values (&rest val-forms)
1566 "Produce multiple values (zero or more). Each arg is one value.
1567 See also `multiple-value-bind', which is one way to examine the
1568 multiple values produced by a form. If the containing form or caller
1569 does not check specially to see multiple values, it will see only
1571 (setq *mvalues-values* val-forms)
1572 (setq *mvalues-count* (length *mvalues-values*))
1573 (car *mvalues-values*))
1575 (defun values-list (&optional val-forms)
1576 "Produce multiple values (zero or mode). Each element of LIST is one value.
1577 This is equivalent to (apply 'values LIST)."
1578 (cond ((nlistp val-forms)
1579 (error "Argument to values-list must be a list, not `%s'"
1580 (prin1-to-string val-forms))))
1581 (setq *mvalues-values* val-forms)
1582 (setq *mvalues-count* (length *mvalues-values*))
1583 (car *mvalues-values*))
1585 ;;; Callers that want to see the multiple values use these macros.
1587 (defmacro multiple-value-list (form)
1588 "Execute FORM and return a list of all the (multiple) values FORM produces.
1589 See `values' and `multiple-value-bind'."
1591 (list 'setq '*mvalues-count* nil)
1592 (list 'let (list (list 'it '(gensym)))
1593 (list 'set 'it form)
1594 (list 'if '*mvalues-count*
1595 (list 'copy-sequence '*mvalues-values*)
1597 (list 'setq '*mvalues-count* 1)
1598 (list 'setq '*mvalues-values*
1599 (list 'list (list 'symbol-value 'it)))
1600 (list 'copy-sequence '*mvalues-values*))))))
1602 (defmacro multiple-value-call (function &rest args)
1603 "Call FUNCTION on all the values produced by the remaining arguments.
1604 (multiple-value-call '+ (values 1 2) (values 3 4)) is 10."
1605 (let* ((result (gentemp))
1607 (list 'apply (list 'function (eval function))
1608 (list 'let* (list (list result '()))
1609 (list 'dolist (list arg (list 'quote args) result)
1613 (list 'multiple-value-list
1614 (list 'eval arg)))))))))
1616 (defmacro multiple-value-bind (vars form &rest body)
1617 "Bind VARS to the (multiple) values produced by FORM, then do BODY.
1618 VARS is a list of variables; each is bound to one of FORM's values.
1619 If FORM doesn't make enough values, the extra variables are bound to nil.
1620 (Ordinary forms produce only one value; to produce more, use `values'.)
1621 Extra values are ignored.
1622 BODY (zero or more forms) is executed with the variables bound,
1623 then the bindings are unwound."
1624 (let* ((vals (gentemp)) ;name for intermediate values
1625 (clauses (mv-bind-clausify ;convert into clauses usable
1626 vars vals))) ; in a let form
1628 (cons (list vals (list 'multiple-value-list form))
1632 (defmacro multiple-value-setq (vars form)
1633 "Set VARS to the (multiple) values produced by FORM.
1634 VARS is a list of variables; each is set to one of FORM's values.
1635 If FORM doesn't make enough values, the extra variables are set to nil.
1636 (Ordinary forms produce only one value; to produce more, use `values'.)
1637 Extra values are ignored."
1638 (let* ((vals (gentemp)) ;name for intermediate values
1639 (clauses (mv-bind-clausify ;convert into clauses usable
1640 vars vals))) ; in a setq (after append).
1642 (list (list vals (list 'multiple-value-list form)))
1643 (cons 'setq (apply (function append) clauses)))))
1645 (defmacro multiple-value-prog1 (form &rest body)
1646 "Evaluate FORM, then BODY, then produce the same values FORM produced.
1647 Thus, (multiple-value-prog1 (values 1 2) (foobar)) produces values 1 and 2.
1648 This is like `prog1' except that `prog1' would produce only one value,
1649 which would be the first of FORM's values."
1650 (let* ((heldvalues (gentemp)))
1652 (cons (list (list heldvalues (list 'multiple-value-list form)))
1653 (append body (list (list 'values-list heldvalues)))))))
1655 ;;; utility functions
1657 ;;; mv-bind-clausify makes the pairs needed to have the variables in
1658 ;;; the variable list correspond with the values returned by the form.
1659 ;;; vals is a fresh symbol that intervenes in all the bindings.
1661 (defun mv-bind-clausify (vars vals)
1662 "MV-BIND-CLAUSIFY VARS VALS => Auxiliary list
1663 Forms a list of pairs `(,(nth i vars) (nth i vals)) for i from 0 to
1664 the length of VARS (a list of symbols). VALS is just a fresh symbol."
1665 (if (or (nlistp vars)
1666 (notevery 'symbolp vars))
1667 (error "expected a list of symbols, not `%s'"
1668 (prin1-to-string vars)))
1669 (let* ((nvars (length vars))
1671 (dotimes (n nvars clauses)
1672 (setq clauses (cons (list (nth n vars)
1673 (list 'nth n vals)) clauses)))))
1675 ;;;; end of cl-multiple-values.el
1678 ;;;; This file provides integer arithmetic extensions. Although
1679 ;;;; Emacs Lisp doesn't really support anything but integers, that
1680 ;;;; has still to be made to look more or less standard.
1683 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
1684 ;;;; (quiroz@cs.rochester.edu)
1687 (defun plusp (number)
1688 "True if NUMBER is strictly greater than zero."
1691 (defun minusp (number)
1692 "True if NUMBER is strictly less than zero."
1695 (defun oddp (number)
1696 "True if INTEGER is not divisible by 2."
1697 (/= (% number 2) 0))
1699 (defun evenp (number)
1700 "True if INTEGER is divisible by 2."
1704 "Return the absolute value of NUMBER."
1709 (defun signum (number)
1710 "Return -1, 0 or 1 according to the sign of NUMBER."
1718 (defun gcd (&rest integers)
1719 "Return the greatest common divisor of all the arguments.
1720 The arguments must be integers. With no arguments, value is zero."
1721 (let ((howmany (length integers)))
1722 (cond ((= howmany 0)
1725 (abs (car integers)))
1727 (apply (function gcd)
1728 (cons (gcd (nth 0 integers) (nth 1 integers))
1729 (nthcdr 2 integers))))
1731 ;; essentially the euclidean algorithm
1732 (when (zerop (* (nth 0 integers) (nth 1 integers)))
1733 (error "a zero argument is invalid for `gcd'"))
1734 (do* ((absa (abs (nth 0 integers))) ; better to operate only
1735 (absb (abs (nth 1 integers))) ;on positives.
1736 (dd (max absa absb)) ; setup correct order for the
1737 (ds (min absa absb)) ;succesive divisions.
1738 ;; intermediate results
1742 (done nil) ; flag: end of iterations
1743 (result 0)) ; final value
1747 (cond ((zerop r) (setq done t) (setq result ds))
1748 (t (setq dd ds) (setq ds r))))))))
1750 (defun lcm (integer &rest more)
1751 "Return the least common multiple of all the arguments.
1752 The arguments must be integers and there must be at least one of them."
1753 (let ((howmany (length more))
1756 prod ; intermediate product
1757 (yetmore (nthcdr 1 more)))
1758 (cond ((zerop howmany)
1760 ((> howmany 1) ; recursive case
1761 (apply (function lcm)
1762 (cons (lcm a b) yetmore)))
1763 (t ; base case, just 2 args
1769 (/ (abs prod) (gcd a b))))))))
1771 (defun isqrt (number)
1772 "Return the integer square root of NUMBER.
1773 NUMBER must not be negative. Result is largest integer less than or
1774 equal to the real square root of the argument."
1775 ;; The method used here is essentially the Newtonian iteration
1776 ;; x[n+1] <- (x[n] + Number/x[n]) / 2
1777 ;; suitably adapted to integer arithmetic.
1778 ;; Thanks to Philippe Schnoebelen <phs@lifia.imag.fr> for suggesting the
1779 ;; termination condition.
1780 (cond ((minusp number)
1781 (error "argument to `isqrt' (%d) must not be negative"
1785 (t ;so (>= number 0)
1786 (do* ((approx 1) ;any positive integer will do
1787 (new 0) ;init value irrelevant
1789 (done (if (> (* approx approx) number)
1792 (setq new (/ (+ approx (/ number approx)) 2)
1793 done (or (= new approx) (= new (+ approx 1)))
1796 (defun floor (number &optional divisor)
1797 "Divide DIVIDEND by DIVISOR, rounding toward minus infinity.
1798 DIVISOR defaults to 1. The remainder is produced as a second value."
1800 ((and (null divisor) ; trivial case
1803 (t ; do the division
1804 (multiple-value-bind
1806 (safe-idiv number divisor)
1811 (t ;opposite-signs case
1814 (let ((q (- (+ q 1))))
1815 (values q (- number (* q divisor)))))))))))
1817 (defun ceiling (number &optional divisor)
1818 "Divide DIVIDEND by DIVISOR, rounding toward plus infinity.
1819 DIVISOR defaults to 1. The remainder is produced as a second value."
1821 ((and (null divisor) ; trivial case
1824 (t ; do the division
1825 (multiple-value-bind
1827 (safe-idiv number divisor)
1831 (values (+ q 1) (- r divisor)))
1833 (values (- q) (+ number (* q divisor)))))))))
1835 (defun truncate (number &optional divisor)
1836 "Divide DIVIDEND by DIVISOR, rounding toward zero.
1837 DIVISOR defaults to 1. The remainder is produced as a second value."
1839 ((and (null divisor) ; trivial case
1842 (t ; do the division
1843 (multiple-value-bind
1845 (safe-idiv number divisor)
1848 ((plusp s) ;same as floor
1851 (values (- q) (+ number (* q divisor)))))))))
1853 (defun round (number &optional divisor)
1854 "Divide DIVIDEND by DIVISOR, rounding to nearest integer.
1855 DIVISOR defaults to 1. The remainder is produced as a second value."
1856 (cond ((and (null divisor) ; trivial case
1859 (t ; do the division
1860 (multiple-value-bind
1862 (safe-idiv number divisor)
1864 ;; adjust magnitudes first, and then signs
1865 (let ((other-r (- (abs divisor) r)))
1866 (cond ((> r other-r)
1870 ;; round to even is mandatory
1873 (setq r (- number (* q divisor)))
1876 (defun mod (number divisor)
1877 "Return remainder of X by Y (rounding quotient toward minus infinity).
1878 That is, the remainder goes with the quotient produced by `floor'."
1879 (multiple-value-bind (q r) (floor number divisor)
1882 (defun rem (number divisor)
1883 "Return remainder of X by Y (rounding quotient toward zero).
1884 That is, the remainder goes with the quotient produced by `truncate'."
1885 (multiple-value-bind (q r) (truncate number divisor)
1888 ;;; internal utilities
1890 ;;; safe-idiv performs an integer division with positive numbers only.
1891 ;;; It is known that some machines/compilers implement weird remainder
1892 ;;; computations when working with negatives, so the idea here is to
1893 ;;; make sure we know what is coming back to the caller in all cases.
1895 ;;; Signum computation fixed by mad@math.keio.JUNET (MAEDA Atusi)
1897 (defun safe-idiv (a b)
1898 "SAFE-IDIV A B => Q R S
1899 Q=|A|/|B|, R is the rest, S is the sign of A/B."
1900 (unless (and (numberp a) (numberp b))
1901 (error "arguments to `safe-idiv' must be numbers"))
1903 (error "cannot divide %d by zero" a))
1904 (let* ((absa (abs a))
1907 (s (* (signum a) (signum b)))
1908 (r (- a (* (* s q) b))))
1911 ;;;; end of cl-arith.el
1914 ;;;; This file provides the setf macro and friends. The purpose has
1915 ;;;; been modest, only the simplest defsetf forms are accepted.
1916 ;;;; Use it and enjoy.
1918 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
1919 ;;;; (quiroz@cs.rochester.edu)
1922 (defkeyword :setf-update-fn
1923 "Property, its value is the function setf must invoke to update a
1924 generalized variable whose access form is a function call of the
1925 symbol that has this property.")
1927 (defkeyword :setf-update-doc
1928 "Property of symbols that have a `defsetf' update function on them,
1929 installed by the `defsetf' from its optional third argument.")
1931 (defmacro setf (&rest pairs)
1932 "Generalized `setq' that can set things other than variable values.
1933 A use of `setf' looks like (setf {PLACE VALUE}...).
1934 The behavior of (setf PLACE VALUE) is to access the generalized variable
1935 at PLACE and store VALUE there. It returns VALUE. If there is more
1936 than one PLACE and VALUE, each PLACE is set from its VALUE before
1937 the next PLACE is evaluated."
1938 (let ((nforms (length pairs)))
1939 ;; check the number of subforms
1940 (cond ((/= (% nforms 2) 0)
1941 (error "odd number of arguments to `setf'"))
1945 ;; this is the recursive case
1947 (do* ;collect the place-value pairs
1948 ((args pairs (cddr args))
1949 (place (car args) (car args))
1950 (value (cadr args) (cadr args))
1952 ((endp args) (nreverse result))
1954 (cons (list 'setf place value)
1957 ;; this is the base case (SETF PLACE VALUE)
1958 (let* ((place (car pairs))
1959 (value (cadr pairs))
1962 ;; dispatch on the type of the PLACE
1963 (cond ((symbolp place)
1964 (list 'setq place value))
1966 (setq head (car place))
1968 (setq updatefn (get head :setf-update-fn)))
1969 (if (or (and (consp updatefn) (eq (car updatefn) 'lambda))
1970 (and (symbolp updatefn)
1972 (let ((defn (symbol-function updatefn)))
1975 (eq (car defn) 'lambda))))))
1976 (cons updatefn (append (cdr place) (list value)))
1977 (multiple-value-bind
1979 (pair-with-newsyms (append (cdr place) (list value)))
1980 ;; this let gets new symbols to ensure adequate
1981 ;; order of evaluation of the subforms.
1984 (cons updatefn newsyms)))))
1986 (error "no `setf' update-function for `%s'"
1987 (prin1-to-string place)))))))))
1989 (defmacro defsetf (accessfn updatefn &optional docstring)
1990 "Define how `setf' works on a certain kind of generalized variable.
1991 A use of `defsetf' looks like (defsetf ACCESSFN UPDATEFN [DOCSTRING]).
1992 ACCESSFN is a symbol. UPDATEFN is a function or macro which takes
1993 one more argument than ACCESSFN does. DEFSETF defines the translation
1994 of (SETF (ACCESFN . ARGS) NEWVAL) to be a form like (UPDATEFN ARGS... NEWVAL).
1995 The function UPDATEFN must return its last arg, after performing the
1996 updating called for."
1997 ;; reject ill-formed requests. too bad one can't test for functionp
1999 (when (not (symbolp accessfn))
2000 (error "first argument of `defsetf' must be a symbol, not `%s'"
2001 (prin1-to-string accessfn)))
2002 ;; update properties
2004 (list 'put (list 'quote accessfn)
2005 :setf-update-fn (list 'function updatefn))
2006 (list 'put (list 'quote accessfn) :setf-update-doc docstring)
2007 ;; any better thing to return?
2008 (list 'quote accessfn)))
2010 ;;; This section provides the "default" setfs for Common-Emacs-Lisp
2011 ;;; The user will not normally add anything to this, although
2012 ;;; defstruct will introduce new ones as a matter of fact.
2014 ;;; Apply is a special case. The Common Lisp
2015 ;;; standard makes the case of apply be useful when the user writes
2016 ;;; something like (apply #'name ...), Emacs Lisp doesn't have the #
2017 ;;; stuff, but it has (function ...). Notice that V18 includes a new
2018 ;;; apply: this file is compatible with V18 and pre-V18 Emacses.
2020 ;;; INCOMPATIBILITY: the SETF macro evaluates its arguments in the
2021 ;;; (correct) left to right sequence *before* checking for apply
2022 ;;; methods (which should really be an special case inside setf). Due
2023 ;;; to this, the lambda expression defsetf'd to apply will succeed in
2024 ;;; applying the right function even if the name was not quoted, but
2025 ;;; computed! That extension is not Common Lisp (nor is particularly
2026 ;;; useful, I think).
2029 (lambda (&rest args)
2030 ;; dissasemble the calling form
2031 ;; "(((quote fn) x1 x2 ... xn) val)" (function instead of quote, too)
2032 (let* ((fnform (car args)) ;functional form
2033 (applyargs (append ;arguments "to apply fnform"
2034 (apply 'list* (butlast (cdr args)))
2036 (newupdater nil)) ; its update-fn, if any
2037 (if (and (symbolp fnform)
2038 (setq newupdater (get fnform :setf-update-fn)))
2039 (apply newupdater applyargs)
2040 (error "can't `setf' to `%s'"
2041 (prin1-to-string fnform)))))
2042 "`apply' is a special case for `setf'")
2047 "`setf' inversion for `aref'")
2051 "`setf' inversion for `nth'")
2055 "`setf' inversion for `nthcdr'")
2059 "`setf' inversion for `elt'")
2062 (lambda (list val) (setnth 0 list val))
2063 "`setf' inversion for `first'")
2066 (lambda (list val) (setnth 1 list val))
2067 "`setf' inversion for `second'")
2070 (lambda (list val) (setnth 2 list val))
2071 "`setf' inversion for `third'")
2074 (lambda (list val) (setnth 3 list val))
2075 "`setf' inversion for `fourth'")
2078 (lambda (list val) (setnth 4 list val))
2079 "`setf' inversion for `fifth'")
2082 (lambda (list val) (setnth 5 list val))
2083 "`setf' inversion for `sixth'")
2086 (lambda (list val) (setnth 6 list val))
2087 "`setf' inversion for `seventh'")
2090 (lambda (list val) (setnth 7 list val))
2091 "`setf' inversion for `eighth'")
2094 (lambda (list val) (setnth 8 list val))
2095 "`setf' inversion for `ninth'")
2098 (lambda (list val) (setnth 9 list val))
2099 "`setf' inversion for `tenth'")
2102 (lambda (list val) (setcdr list val))
2103 "`setf' inversion for `rest'")
2105 (defsetf car setcar "Replace the car of a cons")
2107 (defsetf cdr setcdr "Replace the cdr of a cons")
2110 (lambda (list val) (setcar (nth 0 list) val))
2111 "`setf' inversion for `caar'")
2114 (lambda (list val) (setcar (cdr list) val))
2115 "`setf' inversion for `cadr'")
2118 (lambda (list val) (setcdr (car list) val))
2119 "`setf' inversion for `cdar'")
2122 (lambda (list val) (setcdr (cdr list) val))
2123 "`setf' inversion for `cddr'")
2126 (lambda (list val) (setcar (caar list) val))
2127 "`setf' inversion for `caaar'")
2130 (lambda (list val) (setcar (cadr list) val))
2131 "`setf' inversion for `caadr'")
2134 (lambda (list val) (setcar (cdar list) val))
2135 "`setf' inversion for `cadar'")
2138 (lambda (list val) (setcdr (caar list) val))
2139 "`setf' inversion for `cdaar'")
2142 (lambda (list val) (setcar (cddr list) val))
2143 "`setf' inversion for `caddr'")
2146 (lambda (list val) (setcdr (cadr list) val))
2147 "`setf' inversion for `cdadr'")
2150 (lambda (list val) (setcdr (cdar list) val))
2151 "`setf' inversion for `cddar'")
2154 (lambda (list val) (setcdr (cddr list) val))
2155 "`setf' inversion for `cdddr'")
2158 (lambda (list val) (setcar (caaar list) val))
2159 "`setf' inversion for `caaaar'")
2162 (lambda (list val) (setcar (caadr list) val))
2163 "`setf' inversion for `caaadr'")
2166 (lambda (list val) (setcar (cadar list) val))
2167 "`setf' inversion for `caadar'")
2170 (lambda (list val) (setcar (cdaar list) val))
2171 "`setf' inversion for `cadaar'")
2174 (lambda (list val) (setcdr (caar list) val))
2175 "`setf' inversion for `cdaaar'")
2178 (lambda (list val) (setcar (caddr list) val))
2179 "`setf' inversion for `caaddr'")
2182 (lambda (list val) (setcar (cdadr list) val))
2183 "`setf' inversion for `cadadr'")
2186 (lambda (list val) (setcdr (caadr list) val))
2187 "`setf' inversion for `cdaadr'")
2190 (lambda (list val) (setcar (cddar list) val))
2191 "`setf' inversion for `caddar'")
2194 (lambda (list val) (setcdr (cadar list) val))
2195 "`setf' inversion for `cdadar'")
2198 (lambda (list val) (setcdr (cdaar list) val))
2199 "`setf' inversion for `cddaar'")
2202 (lambda (list val) (setcar (cdddr list) val))
2203 "`setf' inversion for `cadddr'")
2206 (lambda (list val) (setcdr (cdadr list) val))
2207 "`setf' inversion for `cddadr'")
2210 (lambda (list val) (setcdr (caddr list) val))
2211 "`setf' inversion for `cdaddr'")
2214 (lambda (list val) (setcdr (cddar list) val))
2215 "`setf' inversion for `cdddar'")
2218 (lambda (list val) (setcdr (cddr list) val))
2219 "`setf' inversion for `cddddr'")
2221 (defsetf get put "`setf' inversion for `get' is `put'")
2223 (defsetf symbol-function fset
2224 "`setf' inversion for `symbol-function' is `fset'")
2226 (defsetf symbol-plist setplist
2227 "`setf' inversion for `symbol-plist' is `setplist'")
2229 (defsetf symbol-value set
2230 "`setf' inversion for `symbol-value' is `set'")
2232 (defsetf point goto-char
2233 "To set (point) to N, use (goto-char N)")
2235 ;; how about defsetfing other Emacs forms?
2239 ;;; It could be nice to implement define-modify-macro, but I don't
2240 ;;; think it really pays.
2242 (defmacro incf (ref &optional delta)
2243 "(incf REF [DELTA]) -> increment the g.v. REF by DELTA (default 1)"
2246 (list 'setf ref (list '+ ref delta)))
2248 (defmacro decf (ref &optional delta)
2249 "(decf REF [DELTA]) -> decrement the g.v. REF by DELTA (default 1)"
2252 (list 'setf ref (list '- ref delta)))
2254 (defmacro push (item ref)
2255 "(push ITEM REF) -> cons ITEM at the head of the g.v. REF (a list)"
2256 (list 'setf ref (list 'cons item ref)))
2258 (defmacro pushnew (item ref)
2259 "(pushnew ITEM REF): adjoin ITEM at the head of the g.v. REF (a list)"
2260 (list 'setf ref (list 'adjoin item ref)))
2263 "(pop REF) -> (prog1 (car REF) (setf REF (cdr REF)))"
2264 (let ((listname (gensym)))
2265 (list 'let (list (list listname ref))
2267 (list 'car listname)
2268 (list 'setf ref (list 'cdr listname))))))
2272 ;;; Psetf is the generalized variable equivalent of psetq. The right
2273 ;;; hand sides are evaluated and assigned (via setf) to the left hand
2274 ;;; sides. The evaluations are done in an environment where they
2275 ;;; appear to occur in parallel.
2277 (defmacro psetf (&rest body)
2278 "(psetf {var value }...) => nil
2279 Like setf, but all the values are computed before any assignment is made."
2280 (let ((length (length body)))
2281 (cond ((/= (% length 2) 0)
2282 (error "psetf needs an even number of arguments, %d given"
2289 (bodyforms (reverse body)))
2291 (let* ((value (car bodyforms))
2292 (place (cadr bodyforms)))
2293 (setq bodyforms (cddr bodyforms))
2295 (setq setfs (list 'setf place value))
2296 (setq setfs (list 'setf place
2301 ;;; SHIFTF and ROTATEF
2304 (defmacro shiftf (&rest forms)
2305 "(shiftf PLACE1 PLACE2... NEWVALUE)
2306 Set PLACE1 to PLACE2, PLACE2 to PLACE3...
2307 Each PLACE is set to the old value of the following PLACE,
2308 and the last PLACE is set to the value NEWVALUE.
2309 Returns the old value of PLACE1."
2310 (unless (> (length forms) 1)
2311 (error "`shiftf' needs more than one argument"))
2312 (let ((places (butlast forms))
2313 (newvalue (car (last forms))))
2314 ;; the places are accessed to fresh symbols
2315 (multiple-value-bind
2317 (pair-with-newsyms places)
2321 (append (cdr newsyms) (list newvalue))))
2324 (defmacro rotatef (&rest places)
2325 "(rotatef PLACE...) sets each PLACE to the old value of the following PLACE.
2326 The last PLACE is set to the old value of the first PLACE.
2327 Thus, the values rotate through the PLACEs. Returns nil."
2330 (multiple-value-bind
2332 (pair-with-newsyms places)
2337 (append (cdr newsyms) (list (car newsyms)))))
2341 ;;;; This file provides the structures mechanism. See the
2342 ;;;; documentation for Common-Lisp's defstruct. Mine doesn't
2343 ;;;; implement all the functionality of the standard, although some
2344 ;;;; more could be grafted if so desired. More details along with
2348 ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
2349 ;;;; (quiroz@cs.rochester.edu)
2352 (defkeyword :include "Syntax of `defstruct'")
2353 (defkeyword :named "Syntax of `defstruct'")
2354 (defkeyword :conc-name "Syntax of `defstruct'")
2355 (defkeyword :copier "Syntax of `defstruct'")
2356 (defkeyword :predicate "Syntax of `defstruct'")
2357 (defkeyword :print-function "Syntax of `defstruct'")
2358 (defkeyword :type "Syntax of `defstruct'")
2359 (defkeyword :initial-offset "Syntax of `defstruct'")
2361 (defkeyword :structure-doc "Documentation string for a structure.")
2362 (defkeyword :structure-slotsn "Number of slots in structure")
2363 (defkeyword :structure-slots "List of the slot's names")
2364 (defkeyword :structure-indices "List of (KEYWORD-NAME . INDEX)")
2365 (defkeyword :structure-initforms "List of (KEYWORD-NAME . INITFORM)")
2366 (defkeyword :structure-includes
2367 "() or list of a symbol, that this struct includes")
2368 (defkeyword :structure-included-in
2369 "List of the structs that include this")
2372 (defmacro defstruct (&rest args)
2373 "(defstruct NAME [DOC-STRING] . SLOTS) define NAME as structure type.
2374 NAME must be a symbol, the name of the new structure. It could also
2375 be a list (NAME . OPTIONS).
2377 Each option is either a symbol, or a list of a keyword symbol taken from the
2378 list \{:conc-name, :copier, :constructor, :predicate, :include,
2379 :print-function, :type, :initial-offset\}. The meanings of these are as in
2380 CLtL, except that no BOA-constructors are provided, and the options
2381 \{:print-fuction, :type, :initial-offset\} are ignored quietly. All these
2382 structs are named, in the sense that their names can be used for type
2385 The DOC-STRING is established as the `structure-doc' property of NAME.
2387 The SLOTS are one or more of the following:
2388 SYMBOL -- meaning the SYMBOL is the name of a SLOT of NAME
2389 list of SYMBOL and VALUE -- meaning that VALUE is the initial value of
2391 `defstruct' defines functions `make-NAME', `NAME-p', `copy-NAME' for the
2392 structure, and functions with the same name as the slots to access
2393 them. `setf' of the accessors sets their values."
2394 (multiple-value-bind
2395 (name options docstring slotsn slots initlist)
2396 (parse$defstruct$args args)
2397 ;; Names for the member functions come from the options. The
2398 ;; slots* stuff collects info about the slots declared explicitly.
2399 (multiple-value-bind
2400 (conc-name constructor copier predicate
2401 moreslotsn moreslots moreinits included)
2402 (parse$defstruct$options name options slots)
2403 ;; The moreslots* stuff refers to slots gained as a consequence
2404 ;; of (:include clauses). -- Oct 89: Only one :include tolerated
2405 (when (and (numberp moreslotsn)
2407 (setf slotsn (+ slotsn moreslotsn))
2408 (setf slots (append moreslots slots))
2409 (setf initlist (append moreinits initlist)))
2410 (unless (> slotsn 0)
2411 (error "%s needs at least one slot"
2412 (prin1-to-string name)))
2413 (let ((dups (duplicate-symbols-p slots)))
2415 (error "`%s' are duplicates"
2416 (prin1-to-string dups))))
2417 (setq initlist (simplify$inits slots initlist))
2418 (let (properties functions keywords accessors alterators returned)
2419 ;; compute properties of NAME
2423 (list 'put (list 'quote name) :structure-doc
2425 (list 'put (list 'quote name) :structure-slotsn
2427 (list 'put (list 'quote name) :structure-slots
2428 (list 'quote slots))
2429 (list 'put (list 'quote name) :structure-initforms
2430 (list 'quote initlist))
2431 (list 'put (list 'quote name) :structure-indices
2432 (list 'quote (extract$indices initlist))))
2433 ;; If this definition :includes another defstruct,
2434 ;; modify both property lists.
2440 (list 'quote included))
2443 (list 'get (list 'quote (car included))
2444 :structure-included-in))))
2447 (let ((old (gensym)))
2453 :structure-includes))))
2457 :structure-included-in
2460 ;; careful with destructive
2467 :structure-included-in)
2474 ;; If this definition used to be :included in another, warn
2475 ;; that things make break. On the other hand, the redefinition
2476 ;; may be trivial, so don't call it an error.
2477 (let ((old (gensym)))
2480 (list (list old (list 'get
2482 :structure-included-in)))
2485 "`%s' redefined. Should redefine `%s'?"
2487 (list 'prin1-to-string old))))))))
2489 ;; Compute functions associated with NAME. This is not
2490 ;; handling BOA constructors yet, but here would be the place.
2493 (list 'fset (list 'quote constructor)
2495 (list 'lambda (list '&rest 'args)
2496 (list 'make$structure$instance
2499 (list 'fset (list 'quote copier)
2501 (list 'lambda (list 'struct)
2502 (list 'copy-sequence 'struct))))
2503 (let ((typetag (gensym)))
2504 (list 'fset (list 'quote predicate)
2508 'lambda (list 'thing)
2510 (list 'vectorp 'thing)
2513 (list 'elt 'thing 0)))
2521 (list 'length 'thing)
2528 :structure-included-in))))))
2530 ;; compute accessors for NAME's slots
2531 (multiple-value-setq
2532 (accessors alterators keywords)
2533 (build$accessors$for name conc-name predicate slots slotsn))
2534 ;; generate returned value -- not defined by the standard
2539 '(lambda (x) (list 'quote x))
2540 (cons name slots)))))
2543 (nconc properties functions keywords
2544 accessors alterators returned))))))
2546 (defun parse$defstruct$args (args)
2547 "(parse$defstruct$args ARGS) => NAME OPTIONS DOCSTRING SLOTSN SLOTS INITLIST
2548 NAME=symbol, OPTIONS=list of, DOCSTRING=string, SLOTSN=count of slots,
2549 SLOTS=list of their names, INITLIST=alist (keyword . initform)."
2550 (let (name ;args=(symbol...) or ((symbol...)...)
2551 options ;args=((symbol . options) ...)
2552 (docstring "") ;args=(head docstring . slotargs)
2553 slotargs ;second or third cdr of args
2554 (slotsn 0) ;number of slots
2555 (slots '()) ;list of slot names
2556 (initlist '())) ;list of (slot keyword . initform)
2557 ;; extract name and options
2558 (cond ((symbolp (car args)) ;simple name
2559 (setq name (car args)
2561 ((and (listp (car args)) ;(name . options)
2562 (symbolp (caar args)))
2563 (setq name (caar args)
2564 options (cdar args)))
2566 (error "first arg to `defstruct' must be symbol or (symbol ...)")))
2567 (setq slotargs (cdr args))
2568 ;; is there a docstring?
2569 (when (stringp (car slotargs))
2570 (setq docstring (car slotargs)
2571 slotargs (cdr slotargs)))
2572 ;; now for the slots
2573 (multiple-value-bind
2574 (slotsn slots initlist)
2575 (process$slots slotargs)
2576 (values name options docstring slotsn slots initlist))))
2578 (defun process$slots (slots)
2579 "(process$slots SLOTS) => SLOTSN SLOTSLIST INITLIST
2580 Converts a list of symbols or lists of symbol and form into the last 3
2581 values returned by PARSE$DEFSTRUCT$ARGS."
2582 (let ((slotsn (length slots)) ;number of slots
2583 slotslist ;(slot1 slot2 ...)
2584 initlist) ;((:slot1 . init1) ...)
2586 ((ptr slots (cdr ptr))
2587 (this (car ptr) (car ptr)))
2589 (cond ((symbolp this)
2590 (setq slotslist (cons this slotslist))
2591 (setq initlist (acons (keyword-of this) nil initlist)))
2593 (symbolp (car this)))
2594 (let ((name (car this))
2596 ;; this silently ignores any slot options. bad...
2597 (setq slotslist (cons name slotslist))
2598 (setq initlist (acons (keyword-of name) form initlist))))
2600 (error "slot should be symbol or (symbol ...), not `%s'"
2601 (prin1-to-string this)))))
2602 (values slotsn (nreverse slotslist) (nreverse initlist))))
2604 (defun parse$defstruct$options (name options slots)
2605 "(parse$defstruct$options name OPTIONS SLOTS) => many values
2606 A defstruct named NAME, with options list OPTIONS, has already slots SLOTS.
2607 Parse the OPTIONS and return the updated form of the struct's slots and other
2608 information. The values returned are:
2610 CONC-NAME is the string to use as prefix/suffix in the methods,
2611 CONST is the name of the official constructor,
2612 COPIER is the name of the structure copier,
2613 PRED is the name of the type predicate,
2614 MORESLOTSN is the number of slots added by :include,
2615 MORESLOTS is the list of slots added by :include,
2616 MOREINITS is the list of initialization forms added by :include,
2617 INCLUDED is nil, or the list of the symbol added by :include"
2618 (let* ((namestring (symbol-name name))
2619 ;; to build the return values
2620 (conc-name (concat namestring "-"))
2621 (const (intern (concat "make-" namestring)))
2622 (copier (intern (concat "copy-" namestring)))
2623 (pred (intern (concat namestring "-p")))
2628 option-head ;When an option is not a plain
2629 option-second ; keyword, it must be a list of
2630 option-rest ; the form (head second . rest)
2631 these-slotsn ;When :include is found, the
2632 these-slots ; info about the included
2633 these-inits ; structure is added here.
2634 included ;NIL or (list INCLUDED)
2636 ;; Values above are the defaults. Now we read the options themselves
2637 (dolist (option options)
2638 ;; 2 cases arise, as options must be a keyword or a list
2645 (error "can't recognize option `%s'"
2646 (prin1-to-string option)))))
2647 ((and (listp option)
2648 (keywordp (setq option-head (car option))))
2649 (setq option-second (second option))
2650 (setq option-rest (nthcdr 2 option))
2655 ((stringp option-second)
2657 ((null option-second)
2660 (error "`%s' is invalid as `conc-name'"
2661 (prin1-to-string option-second))))))
2665 ((and (symbolp option-second)
2669 (error "can't recognize option `%s'"
2670 (prin1-to-string option))))))
2672 (:constructor ;no BOA-constructors allowed
2675 ((and (symbolp option-second)
2679 (error "can't recognize option `%s'"
2680 (prin1-to-string option))))))
2684 ((and (symbolp option-second)
2688 (error "can't recognize option `%s'"
2689 (prin1-to-string option))))))
2691 (unless (symbolp option-second)
2692 (error "arg to `:include' should be a symbol, not `%s'"
2693 (prin1-to-string option-second)))
2694 (setq these-slotsn (get option-second :structure-slotsn)
2695 these-slots (get option-second :structure-slots)
2696 these-inits (get option-second :structure-initforms))
2697 (unless (and (numberp these-slotsn)
2699 (error "`%s' is not a valid structure"
2700 (prin1-to-string option-second)))
2702 (error "`%s' already includes `%s', can't include `%s' too"
2703 name (car included) option-second)
2704 (push option-second included))
2705 (multiple-value-bind
2706 (xtra-slotsn xtra-slots xtra-inits)
2707 (process$slots option-rest)
2708 (when (> xtra-slotsn 0)
2709 (dolist (xslot xtra-slots)
2710 (unless (memq xslot these-slots)
2711 (error "`%s' is not a slot of `%s'"
2712 (prin1-to-string xslot)
2713 (prin1-to-string option-second))))
2714 (setq these-inits (append xtra-inits these-inits)))
2715 (setq moreslotsn (+ moreslotsn these-slotsn))
2716 (setq moreslots (append these-slots moreslots))
2717 (setq moreinits (append these-inits moreinits))))
2718 ((:print-function :type :initial-offset)
2721 (error "can't recognize option `%s'"
2722 (prin1-to-string option)))))
2724 (error "can't recognize option `%s'"
2725 (prin1-to-string option)))))
2726 ;; Return values found
2727 (values conc-name const copier pred
2728 moreslotsn moreslots moreinits
2731 (defun simplify$inits (slots initlist)
2732 "(simplify$inits SLOTS INITLIST) => new INITLIST
2733 Removes from INITLIST - an ALIST - any shadowed bindings."
2734 (let ((result '()) ;built here
2737 (dolist (slot slots)
2738 (setq key (keyword-of slot))
2739 (setq result (acons key (cdr (assoc key initlist)) result)))
2742 (defun extract$indices (initlist)
2743 "(extract$indices INITLIST) => indices list
2744 Kludge. From a list of pairs (keyword . form) build a list of pairs
2745 of the form (keyword . position in list from 0). Useful to precompute
2746 some of the work of MAKE$STRUCTURE$INSTANCE."
2749 (dolist (entry initlist (nreverse result))
2750 (setq result (acons (car entry) index result)
2751 index (+ index 1)))))
2753 (defun build$accessors$for (name conc-name predicate slots slotsn)
2754 "(build$accessors$for NAME PREDICATE SLOTS SLOTSN) => FSETS DEFSETFS KWDS
2755 Generate the code for accesors and defsetfs of a structure called
2756 NAME, whose slots are SLOTS. Also, establishes the keywords for the
2762 (canonic "")) ;slot name with conc-name prepended
2765 (nreverse accessors) (nreverse alterators) (nreverse keywords)))
2766 (setq canonic (intern (concat conc-name (symbol-name (nth i slots)))))
2769 (list 'fset (list 'quote canonic)
2771 (list 'lambda (list 'object)
2773 (list (list predicate 'object)
2774 (list 'aref 'object (1+ i)))
2777 "`%s' is not a struct %s"
2778 (list 'prin1-to-string
2780 (list 'prin1-to-string
2786 (list 'defsetf canonic
2787 (list 'lambda (list 'object 'newval)
2789 (list (list predicate 'object)
2790 (list 'aset 'object (1+ i) 'newval))
2794 (list 'prin1-to-string
2796 (list 'prin1-to-string
2801 (cons (list 'defkeyword (keyword-of (nth i slots)))
2804 (defun make$structure$instance (name args)
2805 "(make$structure$instance NAME ARGS) => new struct NAME
2806 A struct of type NAME is created, some slots might be initialized
2807 according to ARGS (the &rest argument of MAKE-name)."
2808 (unless (symbolp name)
2809 (error "`%s' is not a possible name for a structure"
2810 (prin1-to-string name)))
2811 (let ((initforms (get name :structure-initforms))
2812 (slotsn (get name :structure-slotsn))
2813 (indices (get name :structure-indices))
2814 initalist ;pairlis'd on initforms
2815 initializers ;definitive initializers
2817 ;; check sanity of the request
2818 (unless (and (numberp slotsn)
2820 (error "`%s' is not a defined structure"
2821 (prin1-to-string name)))
2822 (unless (evenp (length args))
2823 (error "slot initializers `%s' not of even length"
2824 (prin1-to-string args)))
2825 ;; analyze the initializers provided by the call
2826 (multiple-value-bind
2827 (speckwds specvals) ;keywords and values given
2828 (unzip-list args) ; by the user
2829 ;; check that all the arguments are introduced by keywords
2830 (unless (every (function keywordp) speckwds)
2831 (error "all of the names in `%s' should be keywords"
2832 (prin1-to-string speckwds)))
2833 ;; check that all the keywords are known
2834 (dolist (kwd speckwds)
2835 (unless (numberp (cdr (assoc kwd indices)))
2836 (error "`%s' is not a valid slot name for %s"
2837 (prin1-to-string kwd) (prin1-to-string name))))
2841 (do* ;;protect values from further evaluation
2842 ((ptr specvals (cdr ptr))
2843 (val (car ptr) (car ptr))
2845 ((endp ptr) (nreverse result))
2847 (cons (list 'quote val)
2849 (copy-sequence initforms)))
2850 ;; compute definitive initializers
2852 (do* ;;gather the values of the most definitive forms
2853 ((ptr indices (cdr ptr))
2854 (key (caar ptr) (caar ptr))
2856 ((endp ptr) (nreverse result))
2858 (cons (eval (cdr (assoc key initalist))) result))))
2859 ;; do real initialization
2860 (apply (function vector)
2861 (cons name initializers)))))
2863 ;;;; end of cl-structs.el
2865 ;;; For lisp-interaction mode, so that multiple values can be seen when passed
2866 ;;; back. Lies every now and then...
2868 (defvar - nil "form currently under evaluation")
2869 (defvar + nil "previous -")
2870 (defvar ++ nil "previous +")
2871 (defvar +++ nil "previous ++")
2872 (defvar / nil "list of values returned by +")
2873 (defvar // nil "list of values returned by ++")
2874 (defvar /// nil "list of values returned by +++")
2875 (defvar * nil "(first) value of +")
2876 (defvar ** nil "(first) value of ++")
2877 (defvar *** nil "(first) value of +++")
2879 (defun cl-eval-print-last-sexp ()
2880 "Evaluate sexp before point; print value\(s\) into current buffer.
2881 If the evaled form returns multiple values, they are shown one to a line.
2882 The variables -, +, ++, +++, *, **, ***, /, //, /// have their usual meaning.
2884 It clears the multiple-value passing mechanism, and does not pass back
2885 multiple values. Use this only if you are debugging cl.el and understand well
2886 how the multiple-value stuff works, because it can be fooled into believing
2887 that multiple values have been returned when they actually haven't, for
2889 \(identity \(values nil 1\)\)
2890 However, even when this fails, you can trust the first printed value to be
2891 \(one of\) the returned value\(s\)."
2893 ;; top level call, can reset mvalues
2894 (setq *mvalues-count* nil
2895 *mvalues-values* nil)
2896 (setq - (car (read-from-string
2898 (let ((stab (syntax-table)))
2901 (set-syntax-table emacs-lisp-mode-syntax-table)
2904 (set-syntax-table stab)))
2915 (cond ((or (null *mvalues-count*) ;mvalues mechanism not used
2916 (not (eq * (car *mvalues-values*))))
2917 (print * (current-buffer)))
2918 ((null /) ;no values returned
2919 (terpri (current-buffer)))
2920 (t ;more than zero mvalues
2921 (terpri (current-buffer))
2922 (mapcar (function (lambda (value)
2923 (prin1 value (current-buffer))
2924 (terpri (current-buffer))))
2926 (setq *mvalues-count* nil ;make sure
2927 *mvalues-values* nil))
2929 ;;;; More LISTS functions
2932 ;;; Some mapping functions on lists, commonly useful.
2933 ;;; They take no extra sequences, to go along with Emacs Lisp's MAPCAR.
2935 (defun mapc (function list)
2936 "(MAPC FUNCTION LIST) => LIST
2937 Apply FUNCTION to each element of LIST, return LIST.
2938 Like mapcar, but called only for effect."
2941 (funcall function (car args))
2942 (setq args (cdr args))))
2945 (defun maplist (function list)
2946 "(MAPLIST FUNCTION LIST) => list'ed results of FUNCTION on cdrs of LIST
2947 Apply FUNCTION to successive sublists of LIST, return the list of the results"
2951 (setq results (cons (funcall function args) results)
2953 (nreverse results)))
2955 (defun mapl (function list)
2956 "(MAPL FUNCTION LIST) => LIST
2957 Apply FUNCTION to successive cdrs of LIST, return LIST.
2958 Like maplist, but called only for effect."
2961 (funcall function args)
2962 (setq args (cdr args)))
2965 (defun mapcan (function list)
2966 "(MAPCAN FUNCTION LIST) => nconc'd results of FUNCTION on LIST
2967 Apply FUNCTION to each element of LIST, nconc the results.
2968 Beware: nconc destroys its first argument! See copy-list."
2972 (setq results (nconc (funcall function (car args)) results)
2974 (nreverse results)))
2976 (defun mapcon (function list)
2977 "(MAPCON FUNCTION LIST) => nconc'd results of FUNCTION on cdrs of LIST
2978 Apply FUNCTION to successive sublists of LIST, nconc the results.
2979 Beware: nconc destroys its first argument! See copy-list."
2983 (setq results (nconc (funcall function args) results)
2985 (nreverse results)))
2989 (defun copy-list (list)
2990 "Build a copy of LIST"
2993 (defun copy-tree (tree)
2994 "Build a copy of the tree of conses TREE
2995 The argument is a tree of conses, it is recursively copied down to
2996 non conses. Circularity and sharing of substructure are not
2997 necessarily preserved."
2999 (cons (copy-tree (car tree))
3000 (copy-tree (cdr tree)))
3003 ;;; reversals, and destructive manipulations of a list's spine
3005 (defun revappend (x y)
3006 "does what (append (reverse X) Y) would, only faster"
3009 (revappend (cdr x) (cons (car x) y))))
3011 (defun nreconc (x y)
3012 "does (nconc (nreverse X) Y) would, only faster
3013 Destructive on X, be careful."
3016 ;; reuse the first cons of x, making it point to y
3017 (nreconc (cdr x) (prog1 x (rplacd x y)))))
3019 (defun nbutlast (list &optional n)
3020 "Side-effected LIST truncated N+1 conses from the end.
3021 This is the destructive version of BUTLAST. Returns () and does not
3022 modify the LIST argument if the length of the list is not at least N."
3023 (when (null n) (setf n 1))
3024 (let ((length (list-length list)))
3025 (cond ((null length)
3030 (setnthcdr (- length n) list nil)
3035 (defun subst (new old tree)
3036 "NEW replaces OLD in a copy of TREE
3037 Uses eql for the test."
3038 (subst-if new (function (lambda (x) (eql x old))) tree))
3040 (defun subst-if-not (new test tree)
3041 "NEW replaces any subtree or leaf that fails TEST in a copy of TREE"
3042 ;; (subst-if new (function (lambda (x) (not (funcall test x)))) tree)
3043 (cond ((not (funcall test tree))
3048 (let ((head (subst-if-not new test (car tree)))
3049 (tail (subst-if-not new test (cdr tree))))
3050 ;; If nothing changed, return originals. Else use the new
3051 ;; components to assemble a new tree.
3052 (if (and (eql head (car tree))
3053 (eql tail (cdr tree)))
3055 (cons head tail))))))
3057 (defun subst-if (new test tree)
3058 "NEW replaces any subtree or leaf that satisfies TEST in a copy of TREE"
3059 (cond ((funcall test tree)
3064 (let ((head (subst-if new test (car tree)))
3065 (tail (subst-if new test (cdr tree))))
3066 ;; If nothing changed, return originals. Else use the new
3067 ;; components to assemble a new tree.
3068 (if (and (eql head (car tree))
3069 (eql tail (cdr tree)))
3071 (cons head tail))))))
3073 (defun sublis (alist tree)
3074 "Use association list ALIST to modify a copy of TREE
3075 If a subtree or leaf of TREE is a key in ALIST, it is replaced by the
3076 associated value. Not exactly Common Lisp, but close in spirit and
3077 compatible with the native Emacs Lisp ASSOC, which uses EQUAL."
3078 (let ((toplevel (assoc tree alist)))
3079 (cond (toplevel ;Bingo at top
3081 ((atom tree) ;Give up on this
3084 (let ((head (sublis alist (car tree)))
3085 (tail (sublis alist (cdr tree))))
3086 (if (and (eql head (car tree))
3087 (eql tail (cdr tree)))
3089 (cons head tail)))))))
3091 (defun member-if (predicate list)
3092 "PREDICATE is applied to the members of LIST. As soon as one of them
3093 returns true, that tail of the list if returned. Else NIL."
3094 (catch 'found-member-if
3095 (while (not (endp list))
3096 (if (funcall predicate (car list))
3097 (throw 'found-member-if list)
3098 (setq list (cdr list))))
3101 (defun member-if-not (predicate list)
3102 "PREDICATE is applied to the members of LIST. As soon as one of them
3103 returns false, that tail of the list if returned. Else NIL."
3104 (catch 'found-member-if-not
3105 (while (not (endp list))
3106 (if (funcall predicate (car list))
3107 (setq list (cdr list))
3108 (throw 'found-member-if-not list)))
3111 (defun tailp (sublist list)
3112 "(tailp SUBLIST LIST) => True if SUBLIST is a sublist of LIST."
3114 (while (not (endp list))
3115 (if (eq sublist list)
3116 (throw 'tailp-found t)
3117 (setq list (cdr list))))
3120 ;;; Suggestion of phr%widow.Berkeley.EDU@lilac.berkeley.edu
3122 (defmacro declare (&rest decls)
3123 "Ignore a Common-Lisp declaration."
3124 "declarations are ignored in this implementation")
3126 (defun proclaim (&rest decls)
3127 "Ignore a Common-Lisp proclamation."
3128 "declarations are ignored in this implementation")
3130 (defmacro the (type form)
3131 "(the TYPE FORM) macroexpands to FORM
3132 No checking is even attempted. This is just for compatibility with