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