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